1!$Id:$
2      subroutine pnewprob(isw)
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: Start a new problem
11
12!      Note:    Statements in this routine were removed from pcontr.f
13!               to permit better control on starting new problems.
14
15!      Inputs:
16!        isw    -  Switch control on actions
17
18!      Outputs:
19!        Problem control parameters through common blocks.
20!-----[--.----+----.----+----.-----------------------------------------]
21      implicit   none
22
23      include   'allotd.h'
24      include   'allotn.h'
25      include   'augdat.h'
26      include   'bdata.h'
27      include   'cblend.h'
28      include   'cdata.h'
29      include   'cdat1.h'
30      include   'comfil.h'
31      include   'compac.h'
32      include   'comsav.h'
33      include   'contrl.h'
34      include   'cornum.h'
35      include   'corset.h'
36      include   'ddata.h'
37      include   'dstars.h'
38      include   'edgdat.h'
39      include   'elpers.h'
40      include   'errchk.h'
41      include   'gltran.h'
42      include   'idata1.h'
43      include   'idptr.h'
44      include   'iodata.h'
45      include   'iofile.h'
46      include   'ioincl.h'
47      include   'iosave.h'
48      include   'mdata.h'
49      include   'mxsiz.h'
50      include   'nblend.h'
51      include   'pdata5.h'
52      include   'pdata6.h'
53      include   'pfeapb.h'
54      include   'pglob1.h'
55      include   'pointer.h'
56      include   'pmod2d.h'
57      include   'print.h'
58      include   'qudshp.h'
59      include   'refng.h'
60      include   'sdata.h'
61      include   'setups.h'
62      include   'umac1.h'
63      include   'vdata.h'
64      include   'comblk.h'
65
66      character  fileck*128
67      logical    errs,oprt,setvar,palloc,tinput,vinput,pcomp
68      logical    contrfl,lopen
69      character  cdate*24, ctext*15
70      integer    isw,iii, i,j, l1,l2,l3,l4,l5,l6
71      real*8     td(12)
72
73      save
74
75!     Jump to outputs
76
77      if(isw.eq.2) then
78        call fdate( cdate )
79        go to 200
80      endif
81
82!     Close any open multiple problem file before starting new problem
83
84      if(prob_on) then
85        call pendprob
86
87!       Remove any existing files from last problem
88
89        call pdelfl()
90
91!       Delete memory use
92
93        do i = ndict,1,-1
94          setvar = palloc(dlist(i),dict(i),0,iprec(i))
95        end do ! i
96
97      endif
98
99!     Start Problem: Read and print control information
100
101      bflg   = .false.
102      gapfl  = .false.
103      hisfl  = .true.
104      incf   = .false.
105      intr   = .false.
106      intx   = .false.
107      nurbfl = .false.
108      call fdate( cdate )
109      ctext   = 'start'
110      contrfl = .true.
111      do while(.not.pcomp(ctext,'    ',4))
112        errck  = tinput(ctext,1,td(2),8)
113        if(    pcomp(ctext,'node',4) .or. pcomp(ctext,'numnp',5)) then
114          numnp = nint(td(2))
115          contrfl = .false.
116        elseif(pcomp(ctext,'elem',4) .or. pcomp(ctext,'numel',5)) then
117          numel = nint(td(2))
118          contrfl = .false.
119        elseif(pcomp(ctext,'mate',4) .or. pcomp(ctext,'nummat',5)) then
120          nummat = nint(td(2))
121          contrfl = .false.
122        elseif(pcomp(ctext,'dime',4) .or. pcomp(ctext,'ndm',3)) then
123          ndm = nint(td(2))
124          contrfl = .false.
125        elseif(pcomp(ctext,'dofs',4) .or. pcomp(ctext,'ndf',3)) then
126          ndf = nint(td(2))
127          contrfl = .false.
128        elseif(pcomp(ctext,'elno',4) .or. pcomp(ctext,'nen',3)) then
129          nen = nint(td(2))
130          contrfl = .false.
131        elseif(pcomp(ctext,'add',3)  .or. pcomp(ctext,'nad',3)) then
132          nad = nint(td(2))
133          contrfl = .false.
134        elseif(pcomp(ctext,'prop',4)  .or. pcomp(ctext,'npd',3)) then
135          npd = nint(td(2))
136          contrfl = .false.
137        elseif(pcomp(ctext,'upro',4)  .or. pcomp(ctext,'nud',3)) then
138          nud = nint(td(2))
139          contrfl = .false.
140        elseif(contrfl) then
141          errck = vinput(ctext,15,td(1),1)
142          if(nint(td(1)).ge.0) then
143            numnp  = nint(td(1))
144            numel  = nint(td(2))
145            nummat = nint(td(3))
146            ndm    = nint(td(4))
147            ndf    = nint(td(5))
148            nen    = nint(td(6))
149            nad    = nint(td(7))
150            npd    = nint(td(8))
151            nud    = nint(td(9))
152            go to 101
153          endif
154        endif
155      end do ! while
156101   nnn    = 0
157
158!     Adjust storage for material parameters
159
160      npd    = max(npd,300)
161      nud    = max(nud,150)
162      ndd    = npd + nud + 1
163
164!     Star node/element initialization
165
166      starnd = 0
167      starel = 0
168
169!     Blending function initialization
170
171      numsn  = 0
172      numsd  = 0
173      numbd  = 0
174
175!     Contact array initialization
176
177      numcels = 0
178      optflg  = .false.
179      optmsh  = .false.
180
181!     Serial & parallel solution by unblocked equations
182
183      pfeap_blk  = .false.
184      pfeap_glob = .false.
185
186!     Set filenames for multiple problem case
187
188      if(irdef.ne.ior) then
189
190        inquire(unit=ior,name=fnamp,exist=errs)
191
192        prob_on = .false.
193        if(errs) then
194
195!         Set multiple problem flag
196
197          prob_on = .true.
198
199!         Save master output file name and unit number
200
201          i = index(flog,' ')
202          if(nprob.eq.0) then
203            if(isw.gt.0) write(iow,2017) flog(1:i-1)
204            iow_sav  = iow
205            fout_sav = fout
206          endif
207
208!         Extract file name
209
210          i = index(fnamp,' ')
211          if(i.eq.0) i = 128
212          do j = i,1,-1
213            if(pcomp(fnamp(j:j),char(47),1) .or.       ! char(47) = '/'
214     &         pcomp(fnamp(j:j),char(92),1)) go to 110 ! char(92) = '\'
215          end do ! j
216          j = 0
217110       fnamr = fnamp(j+1:j+21)
218
219!         Set new plot file name
220
221          fnamr(1:1) = 'P'
222          fplt(1:128) = ' '
223          fplt(1: 17) = fnamr
224          i = index(fplt,'.')
225          if(i.gt.0) then
226            fplt(i: 21) = ' '
227          endif
228          i = min(index(fplt,' '), 16)
229          if(i.eq.0) then
230            i = 16
231          endif
232
233!         Increment problem counter or delete output file
234
235          if(keepfl) then
236            nprob = nprob + 1
237          else
238            close(unit = iow, status = 'delete')
239            keepfl = .true.
240            nprob  = max(1,nprob)
241          endif
242
243!         Add problem counter to name
244
245          write(fplt(i:i+2),'(a)') '000'
246          if(nprob.lt.10) then
247            write(fplt(i+2:i+2),'(i1)') nprob
248          elseif(nprob.lt.100) then
249            write(fplt(i+1:i+2),'(i2)') nprob
250          elseif(nprob.lt.1001) then
251            write(fplt(  i:i+2),'(i3)') nprob
252          else
253            write(*,*) 'Exceeded limit of multiple files (PCONTR)'
254          endif
255
256!         Set file names for new problem
257
258          if(isw.gt.0) then
259            iow  = 8
260            fout = fplt
261            fout(1:1) = 'O'
262            fres = fplt
263            fres(1:1) = 'R'
264            fsav = fplt
265            fsav(1:1) = 'S'
266
267!           Create clean output file
268
269            inquire(file=fout,exist=initf)
270            if(initf) then
271              open (unit=iow,file=fout,status='old')
272              close(unit=iow,          status='delete')
273            endif
274            open(unit=iow,file=fout,status='new')
275            if(nprob.gt.1) write(iow,2019)
276            write(iow,2020) nprob,fout
277            inquire(unit=iow_sav,opened=lopen)
278            if(lopen) write(iow_sav,2021) nprob
279          endif
280
281!       Error in file structure
282
283        else
284          write(  *,3003)
285          write(iow,3003)
286          call plstop(.true.)
287        endif
288
289!     Single problem solution
290
291      else
292        prob_on = .false.
293      endif
294
295!     Zero pointer array
296
297      setvar = palloc( 0 ,'START', 0 , 0 )
298
299!     Zero number of dictionary entries
300
301      ndict     = 0
302
303!     If number of nodes, or elements is zero compute number from data
304
305      if(nocount) then
306        oprt        =  prt
307        prt         = .false.
308        ucount      = .true.
309        call pnums()
310        irecrd(isf) =  2
311        prt         =  oprt
312        ucount      = .false.
313
314!       Star node/element re-initialization
315
316        starnd = 0
317        starel = 0
318      endif
319
320!     Output problem size data
321
322200   write(iow,2000) head,cdate,versn,fincld(isf),
323     &               numnp,numel, ndm,ndf,nad,nen, nummat,npd,nud
324
325!     Check that problem has nodes elements, etc.
326
327      if(min(numnp,numel,nummat, ndm,ndf,nen).eq.0) then
328        call plstop(.true.)
329      endif
330
331!     Initialize clock
332
333      call stime()
334
335!     Set parameters for page eject and rotation dof
336
337      o   = '    '
338      errck = .false.
339      lsave = .false.
340      lkflg = .false.
341      initf = .true.
342      cxifl = .false.
343      eanfl = .false.
344      ebcfl = .false.
345      ebsfl = .false.
346      curfl = .false.
347      edifl = .false.
348      efcfl = .false.
349      eprfl = .false.
350      espfl = .false.
351      finflg= .false.
352      surfl = .false.
353      boufl = .false.
354      cprfl = .false.
355      disfl = .false.
356      forfl = .false.
357      angfl = .false.
358      reafl = .false.
359      intfl = .false.
360      tiefl = .true.
361      tief  = .false.
362      stifl = .false.
363
364!     Rotation parameters
365
366      do i = 1,50
367        ia(1,i)  = 1
368        ia(2,i)  = 2
369        ir(1,i)  = 0
370        ir(2,i)  = 0
371        ea(1,i)  = 1
372        ea(2,i)  = 2
373        er(1,i)  = 0
374        er(2,i)  = 0
375        inord(i) = 0
376        exord(i) = 0
377        do j = 1,30
378          ipord(j,i) = 0
379          epord(j,i) = 0
380        end do ! j
381      end do ! i
382      nprof  = 0
383      nsurf  = 0
384      nbouf  = 0
385      ndisf  = 0
386      nforf  = 0
387      nangf  = 0
388      nintf  = 0
389      neang  = 0
390      nebcs  = 0
391      nedis  = 0
392      nefrc  = 0
393      nepro  = 0
394      ncurv  = 0
395      nespi  = 0
396
397!     Zero global parameters
398
399      if(    ndm.le.2) then
400        g2type = 2           ! default plane strain
401      elseif(ndm.eq.3) then
402        g2type = 7           ! default 3-d
403      else
404        g2type = 9           ! unspecified
405      endif
406      gdtype = 1
407      gtdof  = 0
408      gref   = 0
409      do i = 1,3
410        grefx(i)  = 0.0d0
411        gtref(i)  = 0.0d0
412      end do ! i
413      do i = 1,2
414        gray(i) = 0.0d0
415      end do ! i
416      do i = 1,14
417        gfac(i) = 0.0d0
418      end do ! i
419      augf   =  1.0d0        ! Augmenting factor multiplier
420
421!     Set pointers for allocation of mesh arrays
422
423      nen1      = nen + 11
424      nie       = 13 ! 1,2 defined; others are nie, nie-1, etc.
425      nst       = max(nen*ndf + nad,1)
426      nneq      = ndf*numnp
427
428!     Allocate size for arrays for mesh and solution vecors
429
430      l1   = ndm*numnp
431      l2   = max(ndf*numnp,1)
432      l3   = max(nen+1,7*nst,21)
433      l4   = numnp*max(ndf,ndm)
434      l5   = ndf*nen
435      l6   = max(1,numel)
436
437!     Allocate and zero arrays
438
439      setvar = palloc( 26,'DR   ',l4          ,  2)
440      setvar = palloc( 34,'LD   ',l3          ,  1)
441      setvar = palloc( 35,'P    ',nst*3       ,  2)
442      setvar = palloc( 36,'S    ',nst*nst*2   ,  2)
443      setvar = palloc( 39,'TL   ',nen         ,  2)
444      setvar = palloc( 41,'UL   ',nst*14      ,  2)
445      setvar = palloc( 44,'XL   ',max(4,nen)*3,  2)
446      setvar = palloc( 25,'D    ',nummat*ndd  ,  2)
447      setvar = palloc( 32,'IE   ',nummat*nie  ,  1)
448      setvar = palloc(240,'IEDOF',nummat*l5   ,  1)
449      setvar = palloc( 31,'ID   ',l2*2        ,  1)
450      setvar = palloc( 33,'IX   ',nen1*l6     ,  1)
451      setvar = palloc(190,'NDTYP',numnp       ,  1)
452      setvar = palloc(100,'RIXT ',numnp       ,  1)
453      setvar = palloc(181,'RBEN ',l6          ,  1)
454      setvar = palloc( 43,'X    ',l1          ,  2)
455      setvar = palloc( 45,'ANG  ',numnp       ,  2)
456      setvar = palloc( 46,'ANGL ',nen         ,  2)
457      setvar = palloc( 27,'F    ',2*l2        ,  2)
458      setvar = palloc( 28,'F0   ',4*l2        ,  2)
459      setvar = palloc( 29,'FPRO ',2*l2        ,  1)
460      setvar = palloc( 30,'FTN  ',4*l2        ,  2)
461      setvar = palloc( 38,'T    ',numnp       ,  2)
462      setvar = palloc( 40,'U    ',4*l2        ,  2)
463      setvar = palloc( 89,'NREN ',numnp*2     ,  1)
464
465!     Set ID address pointers
466
467      id31    = np(31)
468      idpt(1) = np(31)
469
470!     Set pointers
471
472      npid    = np(31)         ! ID
473      npix    = np(33)         ! IX
474      npuu    = np(40)         ! U
475      npxx    = np(43)         ! X
476      nprn    = np(89)         ! NREN
477      npty    = np(190)        ! NDTYP
478
479!     Set initial numbering in renumber vector and mark nodes as unused.
480
481      do i = 0,numnp-1
482        mr(np( 89)+i      ) = i+1  ! Remap list
483        mr(np( 89)+i+numnp) = i+1  ! Reverse list
484        mr(np(190)+i      ) = 0
485      end do ! i
486
487!     Open file to store material data
488
489      inquire(unit=iwd,name=fileck, opened=errs)
490
491!     Input a mesh from binary file (if it exists)
492
493      iii   =  0
494
495!     Input mesh data from file
496
497      call pmesh(iii,prt,prth)
498
499!     Set edge boundary codes, forces, displacements, and angles
500
501      if(eanfl.or.ebcfl.or.edifl.or.efcfl.or.eprfl) then
502        call pedgin()
503      endif
504
505!     Set cordinate angles, boundary codes, forces, displacements,
506!         proportional load types and surface loads
507
508      if(boufl .or. surfl .or. angfl .or.
509     &   disfl .or. cprfl .or. forfl) then
510        call ploadc()
511      endif
512
513!     Perform simple check on mesh to ensure basic data was input
514
515      setvar = palloc(111,'TEMP1',numnp*ndf, 1)
516      call meshck(mr(np(111)),mr(np(32)),mr(np(240)),mr(np(31)+nneq),
517     &            mr(np(190)),mr(np(33)),nie,nen,nen1,ndf,
518     &            numnp,numel,nummat,errs)
519      setvar = palloc(111,'TEMP1',0, 1)
520      if(errs) then
521        call pdelfl()
522        return
523      endif
524
525!     Compute boundary nodes (before ties)
526
527      if(tiefl) then
528        setvar = palloc( 78,'EXTND',numnp ,1)
529        call pextnd()
530        tiefl  = .false.
531      endif
532
533      tfl = .true.
534
535!     Input/output formats
536
5372000  format(1x,19a4,a3//4x,
538     & 'F I N I T E   E L E M E N T   A N A L Y S I S   P R O G R A M'
539     &     /14x,'FEAPpv (P e r s o n a l   V e r s i o n)',
540     &    //13x,'(C) Regents of the University of California'
541     &     /23x,'All Rights Reserved.'
542     &     //5x,'Solution date: ',a//14x,'VERSION: ',a/14x,'DATE: ',a/
543     &      /5x,'Input Data Filename: ',a/
544     &      /5x,'Number of Nodal Points  - - - - - - :',i9
545     &      /5x,'Number of Elements  - - - - - - - - :',i9/
546     &      /5x,'Spatial Dimension of Mesh - - - - - :',i9
547     &      /5x,'Degrees-of-Freedom/Node (Maximum) - :',i9
548     &      /5x,'Equations/Element       (Maximum) - :',i9
549     &      /5x,'Number Element Nodes    (Maximum) - :',i9/
550     &      /5x,'Number of Material Sets - - - - - - :',i9
551     &      /5x,'Number Parameters/Set   (Program) - :',i9
552     &      /5x,'Number Parameters/Set   (Users  ) - :',i9)
553
5542017  format(/'  Problem definitions are specified by include files.'
555     &      //'  Output for each problem is written to separate files.'
556     &      //'  Check file ',a,' for problem list and errors.')
557
5582019  format(/'  ',70('-'))
559
5602020  format(/'  --> Problem',i4,': Output in file: ',a)
561
5622021  format(/'  --> End Problem',i4)
563
5643003  format(/' *ERROR* PCONTR: File name error')
565
566      end
567