retainednodaldofss.f File Reference

Go to the source code of this file.

Functions/Subroutines
subroutine	retainednodaldofss (inpc, textpart, set, istartset, iendset, ialset, nset, nodeboun, ndirboun, xboun, nboun, nboun_, nk, iamboun, nam, ipompc, nodempc, coefmpc, nmpc, nmpc_, mpcfree, inotr, trab, ikboun, ilboun, ikmpc, ilmpc, nk_, co, labmpc, typeboun, istat, n, iline, ipol, inl, ipoinp, inp, nmethod, iperturb, ipoinpc, vold, mi, istep)

Function/Subroutine Documentation

retainednodaldofss()

subroutine retainednodaldofss	(	character*1, dimension(*)	inpc,
		character*132, dimension(16)	textpart,
		character*81, dimension(*)	set,
		integer, dimension(*)	istartset,
		integer, dimension(*)	iendset,
		integer, dimension(*)	ialset,
		integer	nset,
		integer, dimension(*)	nodeboun,
		integer, dimension(*)	ndirboun,
		real*8, dimension(*)	xboun,
		integer	nboun,
		integer	nboun_,
		integer	nk,
		integer, dimension(*)	iamboun,
		integer	nam,
		integer, dimension(*)	ipompc,
		integer, dimension(3,*)	nodempc,
		real*8, dimension(*)	coefmpc,
		integer	nmpc,
		integer	nmpc_,
		integer	mpcfree,
		integer, dimension(2,*)	inotr,
		real*8, dimension(7,*)	trab,
		integer, dimension(*)	ikboun,
		integer, dimension(*)	ilboun,
		integer, dimension(*)	ikmpc,
		integer, dimension(*)	ilmpc,
		integer	nk_,
		real*8, dimension(3,*)	co,
		character*20, dimension(*)	labmpc,
		character*1, dimension(*)	typeboun,
		integer	istat,
		integer	n,
		integer	iline,
		integer	ipol,
		integer	inl,
		integer, dimension(2,*)	ipoinp,
		integer, dimension(3,*)	inp,
		integer	nmethod,
		integer	iperturb,
		integer, dimension(0:*)	ipoinpc,
		real*8, dimension(0:mi(2),*)	vold,
		integer, dimension(*)	mi,
		integer	istep
	)

!
!     reading the input deck: *RETAINED NODAL DOFS
!
      implicit none
!
      logical fixed
!
      character*1 typeboun(*),type,inpc(*)
      character*20 labmpc(*),label
      character*81 set(*),noset
      character*132 textpart(16)
!
      integer istartset(*),iendset(*),ialset(*),nodeboun(*),
     &  ndirboun(*),ntransl,istep,
     &  nset,nboun,nboun_,istat,n,i,j,k,l,ibounstart,ibounend,
     &  key,nk,iamboun(*),nam,iamplitude,ipompc(*),nodempc(3,*),
     &  nmpc,nmpc_,mpcfree,inotr(2,*),ikboun(*),ilboun(*),ikmpc(*),
     &  ilmpc(*),nk_,ipos,iline,ipol,inl,ipoinp(2,*),inp(3,*),
     &  nmethod,iperturb,ipoinpc(0:*),ktrue,mi(*)
!
      real*8 xboun(*),bounval,coefmpc(*),trab(7,*),co(3,*),
     &  vold(0:mi(2),*)
!
      iamplitude=0
      ntransl=0
      type='C'
      fixed=.false.
      label='                    '
!
      if(istep.lt.1) then
         write(*,*) '*ERROR reading *RETAINED NODAL DOFS:'
         write(*,*) '       *RETAINED NODAL DOFS can only be used'
         write(*,*) '       within a STEP'
         call exit(201)
      endif
!
      do i=2,n
         if(textpart(i)(1:9).eq.'SORTED=NO') then
         else
            write(*,*) 
     &'*WARNING reading *RETAINED NODAL DOFS: parameter not recognized:'
            write(*,*) '         ',
     &                 textpart(i)(1:index(textpart(i),' ')-1)
            call inputwarning(inpc,ipoinpc,iline,
     &"*RETAINED NODAL DOFS%")
         endif
      enddo
!
      do
         call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl,
     &        ipoinp,inp,ipoinpc)
         if((istat.lt.0).or.(key.eq.1)) return
!
         read(textpart(2)(1:10),'(i10)',iostat=istat) ibounstart
         if(istat.gt.0) call inputerror(inpc,ipoinpc,iline,
     &"*RETAINED NODAL DOFS%")
!     
         if(textpart(3)(1:1).eq.' ') then
            ibounend=ibounstart
         else
            read(textpart(3)(1:10),'(i10)',iostat=istat) ibounend
            if(istat.gt.0) call inputerror(inpc,ipoinpc,iline,
     &"*RETAINED NODAL DOFS%")
         endif
!     
         bounval=0.d0
!
         read(textpart(1)(1:10),'(i10)',iostat=istat) l
         if(istat.eq.0) then
            if((l.gt.nk).or.(l.le.0)) then
               write(*,*) '*ERROR reading *RETAINED NODAL DOFS:'
               write(*,*) '       node ',l,' is not defined'
               call exit(201)
            endif
            ktrue=l
            call bounadd(l,ibounstart,ibounend,bounval,
     &        nodeboun,ndirboun,xboun,nboun,nboun_,
     &        iamboun,iamplitude,nam,ipompc,nodempc,
     &        coefmpc,nmpc,nmpc_,mpcfree,inotr,trab,
     &        ntransl,ikboun,ilboun,ikmpc,ilmpc,co,nk,nk_,labmpc,
     &        type,typeboun,nmethod,iperturb,fixed,vold,ktrue,mi,
     &        label)
         else
            read(textpart(1)(1:80),'(a80)',iostat=istat) noset
            noset(81:81)=' '
            ipos=index(noset,' ')
            noset(ipos:ipos)='N'
            do i=1,nset
               if(set(i).eq.noset) exit
            enddo
            if(i.gt.nset) then
               noset(ipos:ipos)=' '
               write(*,*) '*ERROR reading *RETAINED NODAL DOFS:'
               write(*,*) '       node set ',noset
               write(*,*) '       has not yet been defined. '
               call inputerror(inpc,ipoinpc,iline,
     &"*RETAINED NODAL DOFS%")
               call exit(201)
            endif
            do j=istartset(i),iendset(i)
               if(ialset(j).gt.0) then
                  k=ialset(j)
                  ktrue=k
                  call bounadd(k,ibounstart,ibounend,bounval,
     &               nodeboun,ndirboun,xboun,nboun,nboun_,
     &               iamboun,iamplitude,nam,ipompc,nodempc,
     &               coefmpc,nmpc,nmpc_,mpcfree,inotr,trab,
     &               ntransl,ikboun,ilboun,ikmpc,ilmpc,co,nk,nk_,labmpc,
     &               type,typeboun,nmethod,iperturb,fixed,vold,ktrue,
     &               mi,label)
               else
                  k=ialset(j-2)
                  do
                     k=k-ialset(j)
                     if(k.ge.ialset(j-1)) exit
                     ktrue=k
                     call bounadd(k,ibounstart,ibounend,bounval,
     &                 nodeboun,ndirboun,xboun,nboun,nboun_,
     &                 iamboun,iamplitude,nam,ipompc,nodempc,
     &                 coefmpc,nmpc,nmpc_,mpcfree,inotr,trab,
     &                 ntransl,ikboun,ilboun,ikmpc,ilmpc,co,nk,nk_,
     &                 labmpc,type,typeboun,nmethod,iperturb,fixed,
     &                 vold,ktrue,mi,label)
                  enddo
               endif
            enddo
         endif
      enddo
!
      return