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