1!$Id:$
2      subroutine pcontr()
3
4!      * * F E A P * * A Finite Element Analysis Program
5
6!....  Copyright (c) 1984-2017: Regents of the University of California
7!                               All rights reserved
8
9!-----[--.----+----.----+----.-----------------------------------------]
10!      Purpose: Control program for FEAPpv problem input and solution.
11
12!      Inputs:
13!        none
14
15!      Outputs:
16!        none
17!-----[--.----+----.----+----.-----------------------------------------]
18      implicit  none
19
20      include  'allotd.h'
21      include  'bdata.h'
22      include  'cblend.h'
23      include  'cdata.h'
24      include  'cdat1.h'
25      include  'chdata.h'
26      include  'codat.h'
27      include  'contrl.h'
28      include  'corset.h'
29      include  'cornum.h'
30      include  'comfil.h'
31      include  'compac.h'
32      include  'conval.h'
33      include  'crotas.h'
34      include  'debugs.h'
35      include  'dstars.h'
36      include  'edgdat.h'
37      include  'elname.h'
38      include  'errchk.h'
39      include  'hlpdat.h'
40      include  'iodata.h'
41      include  'iofile.h'
42      include  'ioincl.h'
43      include  'iosave.h'
44      include  'linka.h'
45      include  'mdata.h'
46      include  'mxsiz.h'
47      include  'pdata2.h'
48      include  'pdata5.h'
49      include  'pdata6.h'
50      include  'pdatps.h'
51      include  'pointer.h'
52      include  'plflag.h'
53      include  'prflag.h'
54      include  'print.h'
55      include  'psize.h'
56      include  'qudshp.h'
57      include  'refng.h'
58      include  'region.h'
59      include  'sdata.h'
60      include  'umac1.h'
61      include  'vdata.h'
62      include  'comblk.h'
63
64      logical   errs,setvar,palloc,tinput,pcomp,evint,lp_in,cinput
65      logical   cprt,oprt,oprth,mulprob,newprob,usetfl(12)
66      character titl*80,dnam*15, fext*4
67      character uset(12)*4, vtype*4, usub*15, tx(8)*15
68      integer   i, iorsv, j,jj, l1,l2,l3,l4
69      integer   usetno(12), itd(1)
70      real*8    td(12)
71
72      save
73
74!     Default names for manipulation sets
75
76      data      uset / 'man1', 'man2', 'man3', 'man4', 'man5' , 'man6',
77     &                 'man7', 'man8', 'man9', 'ma10', 'ma11' , 'ma12'/
78
79!     Destroy old output file if it exists
80
81      inquire(file=fout,exist=initf)
82      if(initf) then
83        open (unit=iow,file=fout,status='old')
84        close(unit=iow,          status='delete')
85      endif
86
87!     Open files for input and output
88
89      open(unit=ior,file=finp,status='old')
90      open(unit=iow,file=fout,status='new')
91
92!     Initial values for include options
93
94      chflg   = .false.
95      cprt    = .true.
96      everon  = .false.
97      evint   = .false.
98      hdcpy   = .false.
99      incf    = .false.
100      intr    = .false.
101      intx    = .false.
102      lp_in   = .true.
103      newprob = .false.
104      mulprob = .false.
105      nocount = .true.
106      debug   = .false.
107      lread   = .false.
108      lsave   = .false.
109      eofile  = .false.
110      ucount  = .false.
111      lfile   = ios
112      icf     = icl
113      isf     = 1
114      irdef   = ior
115      fincld(1) = finp
116      irecrd(1) = 0
117
118!     Set default to print headers
119
120      prth   = .true.
121
122!     Flags for user manipulation commands
123
124      do j = 1,12
125        usetfl(j) = .false.
126        usetno(j) = 0
127      end do ! j
128
129!     Install user functions
130
131!     Set user element names
132
133      td(1)  = 0.0d0
134      itd(1) = 0
135      do j = 1,15
136        utx(1) = 'user'
137        jj  = j
138        call elmlib(td(1),td(1),td(1),itd(1),td(1),td(1),td(1),
139     &              1,1,1,jj,-1)  ! Can assign a name for element
140        umatn(j) = utx(1)
141      end do ! j
142
143!     Set user mesh input names
144
145      do j = 1,12
146        if(j.lt.10) then
147          write(usub,'(a3,i1)') 'mes',j
148        else
149          write(usub,'(a2,i2)') 'me',j
150        endif
151        uct = usub(1:4)
152        call umshlib(j,tx,prt)
153        umshc(j) = uct
154      end do ! j
155
156!     Set user macro input names
157
158      do j = 1,12
159        if(j.lt.10) then
160          write(usub,'(a3,i1)') 'mac',j
161        else
162          write(usub,'(a2,i2)') 'ma',j
163        endif
164        uct   = usub(1:4)
165        fnamp = ' '
166        call umaclib(j,fnamp,td)
167        umacc(j) = uct
168      end do ! j
169
170!     Set umati model names
171
172      do j = 1,5
173        write(usub,'(a3,i1)') 'mat',j
174        uct = 'mate'
175        call uconst(usub,td,td,td,l1,l2,l3)
176      end do ! j
177      uct       = 'mate'
178      usub(1:4) = 'mat0'
179      call uconst(usub,td,td,td,l1,l2,l3)
180
181!     Set uplot input names
182
183      do j = 1,5
184        write(usub,'(a3,i1)') 'plt',j
185        uct = usub(1:4)
186        call upltlib(j,td)
187        upltc(j) = uct
188      end do ! j
189
190!     Set umanipulation names
191
192      do j = 1,12
193        uct     = uset(j)
194        call usetlib(j)
195        uset(j) = uct
196      end do ! j
197
198!     Input with interactive interactive statements
199
2001     if(intx) then
201        if(cprt) then
202          write(*,2009)
203          ior = -abs(ior)
204        endif
205        errck = tinput(dnam,1,td,0)
206
207!       Read command interactively
208
209        if(pcomp(dnam,'y',1)) then
210          write(*,2010)
211!         read (*,1000,err=900,end=910) yyy
212          if(.not.cinput()) then
213            goto 910
214          end if
215          yyy = record
216          cprt = .true.
217
218!       Read command from current file and turn off intx flag
219
220        else
221          evint = .false.
222          cprt  = .false.
223          intr  = .false.
224          intx  = .false.
225          ior   =  abs(ior)
226          read(ior,1000,err=900,end=910) yyy
227        endif
228
229!     Input from current file
230
231      else
232        ior = abs(ior)
233        read(ior,1000,err=900,end=910) yyy
234      endif
235
236!     Compare with command list
237
238      call pstrip(xxx,yyy,1)
239      l1   = len(xxx)
240      titl = xxx(1:l1)
241
242!     Start solution of new problem
243
244      if(pcomp(titl(1:4),'feap',4)) then
245        go to 100
246
247!     Set count/nocount mode
248
249      elseif(pcomp(titl(1:4),'noco',4)) then
250        nocount = .false.
251
252      elseif(pcomp(titl(1:4),'coun',4)) then
253        nocount = .true.
254
255!     User command sets
256
257      elseif(pcomp(titl(1:4),uset(1),4)) then
258        usetno(1) = usetno(1) + 1
259        usetfl(1) = .true.
260        fext  = 'u1a'
261        go to 300
262      elseif(pcomp(titl(1:4),uset(2),4)) then
263        usetno(2) = usetno(2) + 1
264        usetfl(2) = .true.
265        fext  = 'u2a'
266        go to 300
267      elseif(pcomp(titl(1:4),uset(3),4)) then
268        usetno(3) = usetno(3) + 1
269        usetfl(3) = .true.
270        fext  = 'u3a'
271        go to 300
272      elseif(pcomp(titl(1:4),uset(4),4)) then
273        usetno(4) = usetno(4) + 1
274        usetfl(4) = .true.
275        fext  = 'u4a'
276        go to 300
277      elseif(pcomp(titl(1:4),uset(5),4)) then
278        usetno(5) = usetno(5) + 1
279        usetfl(5) = .true.
280        fext  = 'u5a'
281        go to 300
282
283!     Perform inputs from an include file
284
285      elseif(pcomp(titl(1:4),'incl',4)) then
286        call acheck(titl,yyy,15,80,80)
287        read(yyy,1002,err=900,end=900) titl(1:4),dnam
288        if(pcomp(dnam,'end',3)) then
289          call pincld(dnam)
290          if(evint) then
291            write(*,2005) fnamr
292          endif
293          write(iow,2005) fnamr
294        else
295          fnamr =  dnam
296          call pincld(dnam)
297        endif
298        incf = .true.
299        cprt = .false.
300
301!     Perform inputs for initial conditions
302
303      elseif(pcomp(titl(1:4),'init',4)) then
304        call acheck(titl,yyy,15,80,80)
305        read(yyy,1001,err=900,end=900) titl(1:4),dnam(1:4)
306        call pinitl(dnam,errs)
307        if(errs) return
308
309!     Solution mode
310
311      elseif(pcomp(titl(1:4),'inte',4)) then
312        ior   = -abs(ior)
313        evint = .true.
314        intr  = .true.
315        intx  = .true.
316        cprt  = .true.
317        call pltcur()
318        go to 400
319
320      elseif(pcomp(titl(1:4),'batc',4)) then
321        evint = .false.
322        cprt  = .false.
323        intr  = .false.
324        intx  = .false.
325        go to 400
326
327!     Manual level set: 0 = basic; 1 = advanced; 2 = expert
328
329      elseif(pcomp(titl(1:4),'manu',4)) then
330        call acheck(titl,yyy,15,80,80)
331        read(yyy,1003,err=900,end=911) titl(1:4),hlplev
332        hlplev = max(-1,min(3,hlplev))
333
334!     Mesh manipulations: Link and tie
335
336!     Reset id list to link dof's on different nodes - set by node #
337
338      elseif(pcomp(titl(1:4),'link',4)) then
339        call plinka('lnk ','set')
340        lkflg = .true.
341
342      elseif(pcomp(titl(1:4),'tie' ,3)) then
343        go to 500
344
345!     Parameter sets
346
347      elseif(pcomp(titl(1:4),'para',4) .or.
348     &       pcomp(titl(1:4),'cons',4)) then
349        coflg = .true.
350        call pconst(prt)
351
352!     Loop start
353
354      elseif(pcomp(titl(1:4),'loop',4)) then
355        call acheck(titl,yyy,15,80,80)
356        read(yyy,1002,err=900,end=911) titl(1:4),dnam
357        call ploops(lp_in,dnam,1)
358
359!     Loop end
360
361      elseif(pcomp(titl(1:4),'next',4)) then
362        call acheck(titl,yyy,15,80,80)
363        read(yyy,1002,err=900,end=911) titl(1:4),dnam
364        call ploops(lp_in,dnam,2)
365
366!     Remarks to output file
367
368      elseif(pcomp(titl(1:4),'rema',4)) then
369        write(*,2008) titl(1:78)
370
371!     Stop execution
372
373      elseif(pcomp(titl(1:4),'stop',4)) then
374        call pdelfl()
375        if(evint) write(*,2004) fout
376        if(ior.eq.irdef) return
377
378      endif
379
380!     Read again
381
382      go to 1
383
384!     Start Problem: Read and print control information
385
386100   newprob = .true.
387      do i = 1,20
388        l2      = 4*i
389        l1      = l2 - 3
390        head(i) = titl(l1:l2)
391      end do
392      call pnewprob(1)
393      go to 1
394
395!     [mani] - Perform user manipulation commands
396
397300   errs  = .true.
398      j     = 0
399      do while(errs .and. j.lt.26)
400        j     = j + 1
401        fnamr = fsav
402        write(fext(3:3),'(a1)') char(96+j)
403        call addext(fnamr,fext,18,4)
404        inquire(file = fnamr, exist = errs)
405      end do !
406      call plinka(fext,'set')
407      go to 1
408
409!     Establish profile of resulting equations for stiffness, mass, etc
410!     [batc]h execution
411
412400   if(.not.newprob) then
413        write(*,3001)
414        call plstop(.true.)
415      elseif(intx .and. .not.intr .and. .not.incf) then
416        write(*,3002)
417        go to 1
418      endif
419
420      if(tfl) then
421
422!       If ties have occurred merge boundary conditions, forces & contact
423
424        if(tief) then
425          call tiefor(mr(np(31)+nneq),hr(np(27)),mr(np(79)),ndf,numnp)
426        endif
427
428!       Compute boundary nodes (after ties)
429
430        call pextnd()
431
432!       Allocate memory to store all possible equations
433
434        neq = numnp*ndf
435        setvar = palloc( 21, 'JP1  ', neq, 1)
436
437!       Set user commands
438
439        do j = 1,12
440          fext = 'u1a'
441          write(fext(2:2),'(i1)') j
442            if(usetfl(j)) then
443            do l3 = 1,26
444              write(fext(3:3),'(a1)') char(96+l3)
445              fnamr =  fsav
446              call addext(fnamr,fext,18,4)
447              inquire(file = fnamr, exist = errs)
448              if(errs) then
449                call opnfil(fext,fnamr,-1,ios,prt)
450
451!               Read data from file
452
453                iorsv = ior
454                ior   = ios
455
456                do l1 = 0,36
457                  do l2 = 1,26
458                    vvsave(l2,l1) = vvv(l2,l1)
459                  end do
460                end do
461                oprt  = prt
462                oprth = prth
463
464                read(ior,1004) vtype,fincld(isf),irecrd(isf),prt,prth
465                read(ior,1005) vvv
466
467                call usetlib(j)
468
469                close(ior,status='delete')
470                ior   = iorsv
471
472                do l1 = 0,36
473                  do l2 = 1,26
474                    vvv(l2,l1) = vvsave(l2,l1)
475                  end do
476                end do
477                prt  = oprt
478                prth = oprth
479
480              endif
481            end do ! l3
482          endif
483        end do ! j
484
485!       Determine current profile
486
487        do j = 0,nneq-1
488          mr(np(31)+j) = mr(np(31)+j+nneq)
489        end do
490
491        mxpro = 0
492        mxneq = 0
493
494!       Set current profile
495
496        if(ior.lt.0) write(*,*) ' '
497        call profil(mr(np(21)),mr(np(34)),mr(np(31)),
498     &              mr(np(33)),1,prt)
499        call profil(mr(np(21)),mr(np(34)),mr(np(31)),
500     &              mr(np(33)),2,prt)
501        mxpro = max(mxpro,(mr(np(21)+neq-1)))
502        mxneq = max(mxneq,neq)
503
504!       Set up stress history addresses
505
506        call sethis(mr(np(32)),mr(np(33)),nie,nen,nen1,numel,nummat,prt)
507
508        tfl = .false.
509
510      endif
511
512!     Macro module for establishing solution algorithm
513
514      call pmacr(initf)
515      go to 1
516
517!     Tie nodes within tolerance of one another
518!     [tie ] - merge regions with common coordinates
519
520500   call acheck(titl,yyy,15,80,80)
521      read(yyy,1001,err=900,end=911) titl(1:4),titl(16:19),(td(j),j=1,3)
522
523!     Retrieve current boundary connection status
524
525      if(.not.tief) then
526        setvar = palloc( 79,'IPOS ',numnp,  1)
527        call pseqn(mr(np(79)),numnp)
528        tief = .true.
529      endif
530
531!     Tie line elements to regions
532
533      if(pcomp(titl(16:19),'line',4)) then
534        l2 = max(    1,min(nummat,int(td(1))))
535        call ptiend(mr(np(32)),mr(np(33)),mr(np(78)),mr(np(79)),
536     &              hr(np(43)),l2,nie,nen,nen1,ndm,numel)
537      else
538
539        if(pcomp(titl(16:19),'node',4)) then
540          l1 = max(    1,int(td(1)))
541          l2 = min(numnp,int(td(2)))
542          j     = 0
543          td(2) = 0.0d0
544          write(iow,2011) l1,l2
545        elseif(pcomp(titl(16:19),'regi',4)) then
546          l1 = 1
547          l2 = numnp
548          l3 = max(    0,int(td(1)))
549          l4 = min(mxreg,int(td(2)))
550          j     = -1
551          write(iow,2012) l3,l4
552        elseif(pcomp(titl(16:19),'mate',4)) then
553          l1 = 1
554          l2 = numnp
555          l3 = max(     1,int(td(1)))
556          l4 = min(nummat,max(1,int(td(2))))
557          j     = -2
558          write(iow,2013) l3,l4
559        else
560          j  = nint(td(1))
561          l1 = 1
562          l2 = numnp
563          l3 = 0
564          l4 = 0
565          if(j.gt.0) then
566            write(iow,2014) j,td(2)
567          else
568            write(iow,2015)
569          endif
570        endif
571        setvar = palloc(111,'TEMP1',numnp, 1)
572        setvar = palloc(112,'TEMP2',numnp, 1)
573
574        call tienod(mr(np(33)),hr(np(43)),mr(np(79)),mr(np(111)),
575     &              mr(np(112)),mr(np(78)),ndm,nen,nen1,
576     &              numnp,numel,l1,l2,l3,l4,j,td(2))
577
578        setvar = palloc(112,'TEMP2',0, 1)
579        setvar = palloc(111,'TEMP1',0, 1)
580      endif
581      setvar = palloc(111,'TEMP1',numnp, 1)
582      call poutie(mr(np(111)),mr(np(33)),mr(np(190)),nen,nen1,
583     &            numnp,numel,prt)
584      setvar = palloc(111,'TEMP1',0, 1)
585
586      tfl = .true.
587      go to 1
588
589!     Error treatments
590
591900   call  errclr ('PCONTR')
592      call pdelfl()
593      return
594
595910   if(ior.eq.icf) then
596        call pincld('end')
597        incf = .false.
598        intx = evint
599        cprt = evint
600        go to 1
601      endif
602
603911   call  endclr ('PCONTR',titl)
604      call pdelfl()
605      return
606
607!     Input formats
608
6091000  format(a)
6101001  format(2(a4,11x),3f15.0)
6111002  format(a4,11x,a)
6121003  format(a4,11x,3i15)
6131004  format(a4,2x,a12,i8,2l5)
6141005  format(4f20.0)
615
616!     Output formats
617
6182004  format(/' *End of <FEAPpv> solution,  File: ',a/1x)
6192005  format(/' *End of INCLUDE solution, File: ',a/1x)
6202008  format(/' ',a/)
6212009  format(/1x,'Continue with interactive input options for control?',
622     &          '  <y or n> :',$)
6232010  format(1x,'Specify command (INTEractive, INCLude, etc.)'/' > ',$)
6242011  format(/5x,'Tie nodes from',i8,' to ',i8/1x)
6252012  format(/5x,'Tie from region',i4,' to region',i4/1x)
6262013  format(/5x,'Tie from material',i4,' to material',i4/1x)
6272014  format(/5x,'Tie: direction =',i3,' X =',1p,1e12.5/1x)
6282015  format(/5x,'Tie all nodes with common coordinates'/1x)
629
630!     Error Messages
631
6323001  format(/' *ERROR* Attempt to solve problem before mesh input.'/
633     &        '         Check for error on FEAPpv record.'/1x)
6343002  format(/' *ERROR* Can not do BATCH execution from this mode.'/
635     &        '         Do INTERACTIVE or put in INCLUDE file.'/1x)
636
637      end
638