C ***************************************************************** C * PDE2D (Edition 9.6) file: pde2d.f * C ***************************************************************** C PARAMETER (NEXMP=15) COMMON /EXMP/ LEVEL,IEXMP,DP COMMON /LUNITS/ INTIN,INTOUT,LMESS,LUN,LPARAM,LFORT,LFUNS,INFIL & ,IECHO COMMON /PARMS/ LSCREN,ISMX2D,ISMX3D,UNCOM COMMON /IGUI/ IFGUI LOGICAL UNCOM,YES IFGUI = 0 C INTERACTIVE INPUT INTIN = 5 C INTERACTIVE OUTPUT INTOUT = 6 C UNCOMMENT IF LAHEY LF90 USED: C OPEN (UNIT=*,CARRIAGE CONTROL='LIST') C FILE INPUT (pde2d.in) INFIL = 14 C INPUT ECHO (echo.out) IECHO = 15 OPEN (IECHO,FILE='echo.out',STATUS='UNKNOWN') C FORTRAN OUTPUT FILE LPARAM = 11 OPEN(LPARAM,FILE='main.f',STATUS='UNKNOWN') C SCRATCH FILES LFORT = 12 OPEN(LFORT,STATUS='SCRATCH') LFUNS = 13 OPEN(LFUNS,STATUS='SCRATCH') C ************************************************************** C * * C * LSCREN = NUMBER OF LINES PER TERMINAL SCREEN * C * * C ************************************************************** LSCREN = 22 C ************************************************************** C * * C * ISMX2D = MAX VALUE ALLOWED FOR ISOLVE, 2D PROBLEMS * C * ISMX3D = MAX VALUE ALLOWED FOR ISOLVE, 3D PROBLEMS * C * * C ************************************************************** ISMX2D = 6 ISMX3D = 6 C ************************************************************** C * * C * To automatically activate (uncomment) MATLAB graphics code * C * generation in POSTPR, set * C * UNCOM = .TRUE. * C * * C ************************************************************** UNCOM = .FALSE. C CALL LINUM LUN = LPARAM CALL COM (2,'**************************') CALL COM (2,'* PDE2D 9.6 MAIN PROGRAM *') CALL COM (2,'**************************') IEXMP = 0 CALL MESS (1,1) CALL IFYES(YES) IF (YES) THEN CALL MESS (1,2) CALL IREAD (' ', IEXMP, 0, NEXMP) ENDIF IF (IEXMP.GT.0) THEN CALL MESS (0,3) CALL PAWS ENDIF CALL MESS (1,4) CALL IREAD (' ', IDIM, 0, 3) IF (IDIM.EQ.0) THEN CALL PDE0D ELSE IF (IDIM.EQ.1) THEN CALL MESS (1,5) CALL IREAD (' ', IFEM, 1, 2) IF (IFEM.EQ.1) CALL PDE1DG IF (IFEM.EQ.2) CALL PDE1DC ELSE IF (IDIM.EQ.2) THEN CALL MESS (1,6) CALL IREAD (' ', IFEM, 1, 2) IF (IFEM.EQ.1) CALL PDE2DG IF (IFEM.EQ.2) CALL PDE2DC ELSE IF (IDIM.EQ.3) THEN CALL PDE3D ENDIF STOP END SUBROUTINE PDE0D PARAMETER (NEQNMX=99) LOGICAL YES,PARA,ELL,EIGEN,LINEAR,EVCMPX,DP, & RESTRT,FDIFF,UNCOM COMMON /EXMP/ LEVEL,IEXMP,DP COMMON /LUNITS/ INTIN,INTOUT,LMESS,LUN,LPARAM,LFORT,LFUNS,INFIL & ,IECHO COMMON /UNKNWN/ NUNK(NEQNMX),UNK(NEQNMX) COMMON /PARMS/ LSCREN,ISMX2D,ISMX3D,UNCOM C CHARACTER VARIABLES CHARACTER*79 LINE CHARACTER*8 CNUM8 CHARACTER*7 PARNM(176) CHARACTER*6 CNUM6 CHARACTER*3 UNK,FORB(14) CHARACTER*1 LET1(50),LET2(52) DATA LET1 / & 'A','B','C','D','E','F','G','H','O','P','Q','R','S','U','V','W', & 'X','Y','Z','a','b','c','d','e','f','g','h','o','p','q','r','s', & 'u','v','w','x','y','z','I','J','K','L','M','N','i','j','k','l', & 'm','n'/ DATA LET2 / 'A','B','C','D','E','F','G','H','O','P', & 'Q','R','S','T','U','V','W','X','Y','Z', & 'a','b','c','d','e','f','g','h','o','p', & 'q','r','s','t','u','v','w','x','y','z', & 'I','J','K','L','M','N','i','j','k','l','m','n'/ DATA FORB/ & 'PI ','Pi ','pI ','pi ', & 'DT ','Dt ','dT ','dt ','TF ','Tf ','tF ','tf ','T0 ','t0 '/ C INF = 10000 CALL COM (2,'*** 0D PROBLEM SOLVED ***') CALL MESS (0,7) CALL IFYES (DP) CALL PREC WRITE (LUN,90) NEQNMX LUN = LFORT CALL TEXT ('dimension xgrid(nxgrid),xout8z(0:0),'// & 'tout8z(0:nsave),uout(2,neqn,0:nsave)') CALL TEXT ('allocatable iwrk8z(:),rwrk8z(:)') CALL COM (2,' dimension iwrk8z(iiwk8z),rwrk8z(irwk8z)') CALL TEXT ('character*40 title') CALL TEXT ('logical linear,crankn,noupdt,nodist,fillin,'// & 'evcmpx,adapt,plot,lsqfit,fdiff,econ8z,ncon8z,restrt,gridid') IF (DP) THEN CALL TEXT & ('common/dtdp14/ sint8z(20),bint8z(20),slim8z(20),blim8z(20)') CALL TEXT ('common/dtdp15/ evlr8z,ev0r,evli8z,ev0i,evcmpx') CALL TEXT ('common/dtdp16/ p8z,evr8z(50),evi8z(50)') CALL TEXT ('common/dtdp19/ toler(neqnmx),adapt') CALL TEXT ('common/dtdp30/ econ8z,ncon8z') CALL TEXT ('common/dtdp46/ eps8z,cgtl8z,npmx8z,itype,near8z') ELSE CALL TEXT & ('common/ tdp14/ sint8z(20),bint8z(20),slim8z(20),blim8z(20)') CALL TEXT ('common/ tdp15/ evlr8z,ev0r,evli8z,ev0i,evcmpx') CALL TEXT ('common/ tdp16/ p8z,evr8z(50),evi8z(50)') CALL TEXT ('common/ tdp19/ toler(neqnmx),adapt') CALL TEXT ('common/ tdp30/ econ8z,ncon8z') CALL TEXT ('common/ tdp46/ eps8z,cgtl8z,npmx8z,itype,near8z') ENDIF CALL TEXT ('pi = 4.0*atan(1.d0)') CALL MESS (0,8) CALL TEXT ('NPROB = 1') CALL INVAR ('NPROB',.FALSE.) CALL STATE (IST999) WRITE (LUN,5) IST999 5 FORMAT (6X,'do ',I5,' iprob=1,nprob') CALL MESS (0,9) CALL GUI() CALL GLOBP(LET1,50,LET2,52,FORB,14,PARNM,NPARN) CALL MESS (1,10) CALL IFYES (YES) LEVEL = 2 IF (YES) LEVEL = 3 C RECTANGULAR GRID C CALL COM (2, ' ') CALL TEXT ('xgrid(1) = 0.0') C LUN = LFORT C IDENTIFY TYPE OF PDE CALL MESS (1,11) CALL IREAD (' ',ITYPE,1,3) ELL = ITYPE .EQ. 1 PARA = ITYPE .EQ. 2 EIGEN = ITYPE .EQ. 3 IF (EIGEN) THEN C EIGENVALUE PROBLEM SOLVED CALL COM (2, ' *******EIGENVALUE PROBLEM') CALL MESS (0,12) CALL PAWS CALL TEXT ('ITYPE = 3') CALL COM (2,' ') CALL COM (2,' P8Z = 0.0') LINEAR = .TRUE. CALL TEXT ('linear = .true.') CALL TEXT ('t0 = 0.0') CALL TEXT ('dt = 1.0') CALL TEXT ('crankn = .false.') CALL TEXT ('noupdt = .true.') CALL MESS (0,13) CALL IFYES (EVCMPX) IF (.NOT.EVCMPX) THEN CALL TEXT ('EVCMPX = .FALSE.') CALL MESS (0,14) CALL TEXT ('EV0R = 0.0') CALL GUI() CALL INVAR ('EV0R', .FALSE.) ELSE CALL TEXT ('EVCMPX = .TRUE.') CALL MESS (0,15) CALL TEXT ('EV0R = 0.0') CALL TEXT ('EV0I = 0.0') CALL INVAR ('EV0R', .FALSE.) CALL INVAR ('EV0I', .FALSE.) ENDIF CALL MESS (0,16) CALL TEXT ('NSTEPS = 25') CALL INVAR ('NSTEPS',.FALSE.) ELSE IF (PARA) THEN C TIME DEPENDENT PROBLEM SOLVED CALL COM (2,' *******TIME-DEPENDENT PROBLEM') CALL TEXT ('itype = 2') CALL MESS (0,17) CALL TEXT ('T0 = 0.0') CALL GUI() CALL INVAR ('T0',.FALSE.) CALL GUI() CALL INVAR ('TF',.TRUE.) CALL MESS (0,18) CALL IFYES (LINEAR) IF (LINEAR) THEN CALL TEXT ('LINEAR = .TRUE.') ELSE CALL TEXT ('LINEAR = .FALSE.') ENDIF CALL MESS (0,19) CALL IFYES (YES) CALL GUI() IF (YES) THEN CALL TEXT ('ADAPT = .TRUE.') CALL TEXT ('TOLER(1) = 0.01') CALL INVAR ('TOLER(1)', .FALSE.) IF (LINEAR) CALL MESS (2,20) CALL TEXT ('NOUPDT = .FALSE.') CALL MESS (0,21) ELSE CALL TEXT ('ADAPT = .FALSE.') CALL TEXT ('TOLER(1) = 0.01') IF (LINEAR) THEN CALL MESS (0,20) CALL IFYES (YES) CALL GUI() IF (YES) THEN CALL TEXT ('NOUPDT = .TRUE.') ELSE CALL TEXT ('NOUPDT = .FALSE.') ENDIF ELSE CALL TEXT ('NOUPDT = .FALSE.') ENDIF CALL MESS (0,22) ENDIF CALL GUI() CALL INVAR ('NSTEPS',.TRUE.) CALL TEXT ('dt = (tf-t0)/max(nsteps,1)') CALL MESS (0,23) CALL IFYES (YES) IF (YES) THEN CALL TEXT ('CRANKN = .TRUE.') ELSE CALL TEXT ('CRANKN = .FALSE.') ENDIF ELSE C STEADY STATE PROBLEM SOLVED CALL COM (2,' *******STEADY-STATE PROBLEM') CALL TEXT ('itype = 1') CALL TEXT ('t0 = 0.0') CALL TEXT ('dt = 1.0') CALL TEXT ('crankn = .false.') CALL TEXT ('noupdt = .false.') CALL MESS (0,18) CALL IFYES (LINEAR) IF (LINEAR) THEN CALL TEXT ('LINEAR = .TRUE.') CALL COM (2, ' Number of Newton iterations') CALL TEXT ('NSTEPS = 1') ELSE CALL TEXT ('LINEAR = .FALSE.') CALL MESS (0,24) CALL TEXT ('NSTEPS = 15') CALL INVAR ('NSTEPS',.FALSE.) ENDIF ENDIF LUN = LPARAM CALL MESS (0,25) CALL INPARM ('NEQN',NEQN,1,NEQNMX) LUN = LFORT CALL MESS (1,26) CALL VARNAM(LET1,38,LET2,40,FORB,4,NEQN) IND = MIN(NEQN-1,3) C FINITE DIFFERENCE JACOBIAN? IF (LINEAR) THEN FDIFF = .FALSE. ELSE CALL MESS (0,27) CALL IFYES (FDIFF) ENDIF IF (FDIFF) THEN CALL TEXT ('FDIFF = .TRUE.') ELSE CALL TEXT ('FDIFF = .FALSE.') ENDIF C PDES DEFINED LUN = LFUNS CALL TEXT (' ') CALL TEXT (' ') CALL TEXT & ('subroutine pdes8z(yd8z,i8z,j8z,kint8z,x8z,t,uu8z)') CALL PREC WRITE (LUN,90) NEQNMX 90 FORMAT (6X,'parameter (neqnmx=',I4,')') IF (EIGEN) WRITE (LUN,95) NEQN 95 FORMAT (6X,'parameter (NEQN=',I4,')') CALL COM (2, ' un8z(1,I) hold'// & ' the (rarely used) values') CALL COM (2, ' of UI from the previous'// & ' iteration or time step') IF (DP) THEN CALL TEXT ('common /dtdp4x/un8z(3,neqnmx)') CALL TEXT ('double precision uu8z(3,neqnmx)') ELSE CALL TEXT ('common / tdp4x/un8z(3,neqnmx)') CALL TEXT ('real uu8z(3,neqnmx)') ENDIF IF (EIGEN.AND.(NEQN.GT.1)) CALL TEXT('dimension rho(neqn,neqn)') WRITE (LUN,395) (PARNM(I),I=1,NPARN) DO 130 IEQ = 1,NEQN WRITE (LUN,100) UNK(IEQ)(1:NUNK(IEQ)),IEQ 100 FORMAT(6X,A,' = uu8z(1,',I2,')') 130 CONTINUE CALL TEXT (' if (i8z.eq.0) then') CALL TEXT ('yd8z = 0.0') LUN = LFORT CALL MESS (0,28) CALL IREAD ('NINT', NINT, 0, 20) LUN = LFUNS IF (NINT.GT.0) THEN CALL MESS (0,29 + IND) CALL IADD (3, 'the integrals') DO 140 I=1,NINT CALL VECFUN('INTEGRAL',I,NINT,I,'yd8z',0,'kint8z') 140 CONTINUE ELSE CALL MESS (2,29 + IND) WRITE (LUN,150) 150 FORMAT ('C',50X,'INTEGRAL1 DEFINED',/, & 'C if (kint8z.eq.1) yd8z =',/, & 'C & [DEFAULT SELECTED, DEFINITION COMMENTED OUT]') ENDIF LUN = LFORT CALL TEXT ('nbint = 0') LUN = LFUNS CALL TEXT (' else') IF (EIGEN) THEN CALL MESS (0,33 + IND) CALL IADD (2,'these coefficients') ELSE IF (ELL) THEN CALL MESS (0,37 + IND) CALL IADD (2,'these coefficients') ELSE IF (PARA) THEN CALL MESS (0,41 + IND) CALL IADD (2,'these coefficients') ENDIF CALL TEXT (' if (j8z.eq.0) then') CALL TEXT ('yd8z = 0.0') DO 160 I = 1,NEQN IF (PARA) THEN CALL GUI() DO 159 J = 1,NEQN LL = 100*I+J IF (NEQN.EQ.1) THEN CALL VECFUN ('C',1,1,(-LL),'yd8z',2,'i8z') ELSE IF (NEQN.LE.9) THEN WRITE (CNUM6,157) I,J 157 FORMAT ('C(',I1,',',I1,')') CALL VECFUN (CNUM6,1,1,(-LL),'yd8z',2,'i8z') ELSE WRITE (CNUM8,158) I,J 158 FORMAT ('C(',I2,',',I2,')') CALL VECFUN (CNUM8,1,1,(-LL),'yd8z',2,'i8z') ENDIF 159 CONTINUE ENDIF CALL GUI() CALL VECFUN ('F',I,NEQN,I,'yd8z',0,'i8z') IF (EIGEN) THEN CALL GUI() IF (NEQN .EQ. 1) THEN CALL COM (2, & ' RHO DEFINED') CALL INVAR ('RHO', .TRUE.) ELSE CALL COM (2, & ' RHO DEFINED') CALL INMAT ('RHO', I, I, 1, NEQN, .TRUE.) ENDIF ENDIF 160 CONTINUE IF (EIGEN) THEN IF (DP) THEN CALL TEXT ('call dtdpsx (yd8z,i8z,uu8z,un8z,rho,3,neqn)') ELSE CALL TEXT ('call tdpsx (yd8z,i8z,uu8z,un8z,rho,3,neqn)') ENDIF ENDIF CALL TEXT (' else') IF (.NOT.LINEAR .AND. .NOT.FDIFF) THEN DO 165 I = 1,NEQN DO 164 J = 1,NEQN JJ = 3*(J-1) CALL MATFUN('F', I, NEQN, UNK(J)(1:NUNK(J)), & I, JJ+1, 'yd8z', 0) 164 CONTINUE 165 CONTINUE ENDIF CALL TEXT (' endif') CALL TEXT (' endif') CALL TEXT ('return') CALL TEXT ('end') C INITIAL VALUES SPECIFIED CALL TEXT (' ') CALL TEXT (' ') CALL TEXT ('function u8z(i8z,x8z,t0)') CALL PREC WRITE (LUN,395) (PARNM(I),I=1,NPARN) IF (EIGEN) THEN IF (DP) THEN CALL TEXT ('u8z = dtdpxx()') ELSE CALL TEXT ('u8z = tdpxx()') ENDIF ELSE CALL TEXT ('u8z = 0.0') ENDIF IF ( .NOT.ELL .OR. .NOT.LINEAR) THEN IF (EIGEN) CALL MESS (0,45) IF (ELL) CALL MESS (0,46) IF (PARA) CALL MESS (0,47) CALL IADD (3,'the initial values') DO 170 I = 1,NEQN IF (EIGEN) THEN CALL VECFUN (UNK(I)(1:NUNK(I))//'0',0,1,I, & 'u8z',1,'i8z') ELSE CALL GUI() CALL VECFUN (UNK(I)(1:NUNK(I))//'0',0,1,I, & 'u8z',2,'i8z') ENDIF 170 CONTINUE LUN = LFORT CALL TEXT ('lsqfit = .false.') CALL MESS (0,48) CALL IFYES(RESTRT) IF (RESTRT) THEN CALL TEXT ('RESTRT = .TRUE.') ELSE CALL TEXT ('RESTRT = .FALSE.') ENDIF ELSE LUN = LFORT CALL TEXT ('lsqfit = .false.') CALL TEXT ('RESTRT = .FALSE.') ENDIF CALL TEXT ('gridid = .true.') LUN = LFUNS CALL TEXT ('return') CALL TEXT ('end') C BOUNDARY CONDITIONS DEFINED LUN = LFORT CALL TEXT ('iperdc = 0') C OUTPUT MODIFICATION FUNCTIONS DEFINED LUN = LFUNS CALL TEXT (' ') CALL TEXT (' ') CALL TEXT ('subroutine pmod8z(x8z,t,uu8z,uprint,uxp8z)') CALL PREC CALL TEXT ('dimension uu8z(3,*),uprint(*),uxp8z(*)') IF (DP) THEN CALL TEXT & ('common/dtdp14/sint(20),bint(20),slim8z(20),blim8z(20)') ELSE CALL TEXT & ('common/ tdp14/sint(20),bint(20),slim8z(20),blim8z(20)') ENDIF WRITE (LUN,395) (PARNM(I),I=1,NPARN) DO 250 IEQ = 1,NEQN WRITE (LUN,100) UNK(IEQ)(1:NUNK(IEQ)),IEQ 250 CONTINUE CALL MESS (0,49 + IND) CALL IADD (3,'these variables') CALL COM (2, ' DEFINE UPRINT(*) HERE:') DO 255 I=1,NEQN WRITE (INTOUT,251) UNK(I)(1:NUNK(I)) 251 FORMAT (' Replace ',A,' for postprocessing?') CALL INVEC ('UPRINT',I,I,.FALSE.) 255 CONTINUE CALL TEXT ('return') CALL TEXT ('end') C CALCULATE STORAGE REQUIREMENTS LUN = LPARAM CALL TEXT ('parameter (nxgrid = 1)') CALL COM (2,' DIMENSIONS OF WORK ARRAYS') IRWK = 1 IIWK = 1 CALL COM (2, ' SET TO 1 FOR AUTOMATIC ALLOCATION') WRITE (LUN,260) IRWK,IIWK 260 FORMAT (6X,'PARAMETER (IRWK8Z=',I12,')',/, 6X,'PARAMETER (IIWK8Z=' &,I12,')') C OUTPUT PARAMETERS LUN = LFORT CALL TEXT ('npts8z = 1') CALL TEXT ('xout8z(0) = 0.0') IF (PARA) THEN LUN = LPARAM CALL MESS (0,53) CALL INPARM ('NSAVE', NSAVE, 1, INF) LUN = LFORT ELSE LUN = LPARAM NSAVE = 1 CALL TEXT ('PARAMETER (NSAVE = 1)') LUN = LFORT CALL COM (2, ' SOLUTION SAVED EVERY NOUT ITERATIONS') CALL TEXT ('NOUT = NSTEPS') ENDIF IF (DP) THEN CALL TEXT ('call dtdp1q(nxgrid,neqn,ii8z,ir8z)') ELSE CALL TEXT ('call tdp1q(nxgrid,neqn,ii8z,ir8z)') ENDIF CALL TEXT ('if (iiwk8z.gt.1) ii8z = iiwk8z') CALL TEXT ('if (irwk8z.gt.1) ir8z = irwk8z') CALL COM (2, ' *******allocate workspace') CALL TEXT ('allocate (iwrk8z(ii8z),rwrk8z(ir8z))') CALL TEXT ('plot = .false.') CALL COM (2,' *******call pde solver') IF (DP) THEN CALL TEXT ('call dtdp1x(xgrid, -1, neqn, nint, nbint,'// & ' xout8z, uout, tout8z, iperdc, plot, lsqfit, fdiff,'// & ' npts8z, t0, dt, nsteps, nout, nsave, crankn, noupdt,'// & ' itype, linear, rwrk8z, ir8z, iwrk8z, ii8z, restrt, gridid)') ELSE CALL TEXT ('call tdp1x(xgrid, -1, neqn, nint, nbint,'// & ' xout8z, uout, tout8z, iperdc, plot, lsqfit, fdiff,'// & ' npts8z, t0, dt, nsteps, nout, nsave, crankn, noupdt,'// & ' itype, linear, rwrk8z, ir8z, iwrk8z, ii8z, restrt, gridid)') ENDIF CALL TEXT ('deallocate (iwrk8z,rwrk8z)') IF (EIGEN) THEN WRITE (LUN,270) IST999 270 FORMAT (6X,'if (itype.eq.4) go to ',I5) CALL COM (2, & ' *******UNCOMMENT TO POSTPROCESS ONLY IF CONVERGED') WRITE (LUN,275) IST999 275 FORMAT ('C',6X,'IF (.NOT.ECON8Z) GO TO ',I5) ENDIF IF (ELL.AND.(.NOT.LINEAR)) THEN CALL COM (2, & ' *******UNCOMMENT TO POSTPROCESS ONLY IF CONVERGED') WRITE (LUN,276) IST999 276 FORMAT ('C',6X,'IF (.NOT.NCON8Z) GO TO ',I5) ENDIF CALL COM (2,' *******call user-written postprocessor') CALL TEXT ('call postpr(tout8z,nsave,uout,neqn)') 280 CONTINUE CALL MESS (1,54) IPLIM = 2 IF (.NOT.PARA) IPLIM = 1 CALL IREAD (' ',IPLOT,0,IPLIM) IF (IPLOT .EQ. 0) THEN GO TO 300 ELSE IF (IPLOT .EQ. 1) THEN C TABLE OF VALUES AT OUTPUT POINTS CALL COM (2,' *******TABULAR OUTPUT') CALL MESS (0,55 + IND) CALL IREAD ('IVAR',IVAR,1,NEQN) CALL MESS (0,59) CALL TEXT ('TITLE = '' '' ') CALL INSTR ('TITLE',.FALSE.) IF (DP)THEN CALL TEXT ('call dtdp1f(tout8z,uout(1,ivar,0),'// & 'nsave,neqn,title)') ELSE CALL TEXT ('call tdp1f(tout8z,uout(1,ivar,0),'// & 'nsave,neqn,title)') ENDIF ELSE IF (IPLOT .EQ. 2) THEN C LINE PLOTS CALL COM (2, ' *******LINE PLOTS') CALL MESS (0,55 + IND) CALL IREAD ('IVAR', IVAR, 1, NEQN) CALL COM (2, ' T IS VARIABLE') CALL TEXT ('ics8z = 2') CALL MESS (0,60) CALL TEXT ('UMIN = 0.0') CALL TEXT ('UMAX = 0.0') CALL INVAR ('UMIN', .FALSE.) CALL INVAR ('UMAX', .FALSE.) CALL MESS (0,59) CALL TEXT ('TITLE = '' '' ') CALL INSTR ('TITLE',.FALSE.) CALL TEXT ('is8z = 0') CALL TEXT ('ix8z = 0') IF (DP) THEN CALL TEXT ('call dtdpzp(ics8z,2*ivar-1,tout8z,nsave,'// & 'xout8z,0,uout,neqn,title,umin,umax,ix8z,is8z)') ELSE CALL TEXT ('call tdpzp(ics8z,2*ivar-1,tout8z,nsave,'// & 'xout8z,0,uout,neqn,title,umin,umax,ix8z,is8z)') ENDIF ENDIF GO TO 280 300 CONTINUE C ADD DUMMY PDE2D FUNCTIONS LUN = LFUNS CALL COM (2,' dummy routines') CALL TEXT ('subroutine gb8z(gd8z,ifac8z,i8z,j8z,x,t,uu8z)') CALL PREC CALL TEXT ('return') CALL TEXT ('end') CALL TEXT ('subroutine xy8z(i8z,iarc8z,s,x,y,s0,sf)') CALL PREC CALL TEXT ('return') CALL TEXT ('end') CALL TEXT ('subroutine dis8z(x,y,ktri,triden,shape)') CALL PREC CALL TEXT ('return') CALL TEXT ('end') CALL TEXT ('function fb8z(i8z,iarc8z,ktri,s,x,y,t)') CALL PREC CALL TEXT ('fb8z = 0') CALL TEXT ('return') CALL TEXT ('end') CALL TEXT ('function axis8z(i8z,x,y,z,ical8z)') CALL PREC CALL TEXT ('axis8z = 0') CALL TEXT ('return') CALL TEXT ('end') CALL TEXT ('subroutine tran8z(itrans,x,y,z)') CALL PREC CALL TEXT ('return') CALL TEXT ('end') C WRITE POSTPR CALL TEXT (' ') CALL TEXT (' ') CALL TEXT ( &'subroutine postpr(tout,nsave,uout,neqn)') CALL PREC CALL TEXT ('dimension tout(0:nsave)') CALL TEXT ('dimension uout(2,neqn,0:nsave)') WRITE (LUN,395) (PARNM(I),I=1,NPARN) IF (DP) THEN CALL TEXT ('common /dtdp27/ itask,npes,icomm') CALL TEXT ('common /dtdp46/ eps8z,cgtl8z,npmx8z,itype,near8z') ELSE CALL TEXT ('common / tdp27/ itask,npes,icomm') CALL TEXT ('common / tdp46/ eps8z,cgtl8z,npmx8z,itype,near8z') ENDIF CALL TEXT ('data lun,lud/0,47/') CALL TEXT ('if (itask.gt.0) return') CALL COM (2,'UOUT(1,IEQ,L) = U_IEQ') CALL COM (2,' (possibly as modified by UPRINT,..)') CALL COM (2,' at time/iteration TOUT(L).') CALL COM (2,' ******* ADD POSTPROCESSING CODE HERE:') CALL COM (2,' IN THE EXAMPLE BELOW, MATLAB PLOTFILES pde2d.m,') CALL COM (2,' pde2d.rdm CREATED (REMOVE C! COMMENTS TO ACTIVATE)') CALL COM (3,' if (lun.eq.0) then') CALL COM (3,' lun = 46') CALL COM (3,' open (lun,file=''pde2d.m'')') CALL COM (3,' open (lud,file=''pde2d.rdm'')') CALL COM (3, & ' write (lun,*) ''fid = fopen(''''pde2d.rdm'''');''') CALL COM (3,' endif') CALL COM (3,' do 78753 l=0,nsave') IF (DP) THEN CALL COM (3,' if (tout(l).ne.dtdplx(2)) nsave0 = l') ELSE CALL COM (3,' if (tout(l).ne. tdplx(2)) nsave0 = l') ENDIF CALL COM (4,'78753 continue') CALL COM (3,' write (lud,78754) nsave0') CALL COM (3,' write (lud,78754) neqn') CALL COM (4,'78754 format (i8)') CALL COM (3,' do 78756 l=0,nsave0') CALL COM (3,' write (lud,78757) tout(l)') CALL COM (3,' do 78755 ieq=1,neqn') CALL COM (3,' write (lud,78757) uout(1,ieq,l)') CALL COM (4,'78755 continue') CALL COM (4,'78756 continue') CALL COM (4,'78757 format (e16.8)') CALL COM (2,' ******* WRITE pde2d.m ') CALL COM (3,' call mtdp0d(itype,lun)') CALL TEXT ('return') CALL TEXT ('end') C ENTER USER-SUPPLIED FUNCTIONS CALL MESS (1,61) CALL IFYES (YES) IF (YES) CALL IADD (0,' ') CALL MESS (1,411) LUN = LFORT WRITE (LUN,470) IST999 CALL TEXT ('call endgks') CALL TEXT ('stop') CALL TEXT ('end') LUN = LPARAM WRITE (LUN,395) (PARNM(I),I=1,NPARN) 395 FORMAT (6X,'common/parm8z/ pi',6A7,/,(5X,'&',9A7)) C CONCATENATE PARAMETERS FILE, MAIN PROGRAM, AND SUBPROGRAMS REWIND LFORT 400 CONTINUE READ (LFORT,410,END=420) LINE 410 FORMAT (A79) WRITE (LPARAM,410) LINE GO TO 400 420 CONTINUE REWIND LFUNS 430 CONTINUE READ (LFUNS,410,END=440) LINE WRITE (LPARAM,410) LINE GO TO 430 440 CONTINUE 470 FORMAT (I5,' continue') STOP END SUBROUTINE PDE1DG PARAMETER (NEQNMX=99) PARAMETER (NDELMX=20) LOGICAL YES,EIGEN,PARA,ELL,LINEAR,SYMM,NOMORE,EVCMPX, & FDIFF,DP,RESTRT,FIXL,FIXR,UNCOM COMMON /EXMP/ LEVEL,IEXMP,DP COMMON /LUNITS/ INTIN,INTOUT,LMESS,LUN,LPARAM,LFORT,LFUNS,INFIL & ,IECHO COMMON /UNKNWN/ NUNK(NEQNMX),UNK(NEQNMX) COMMON /PARMS/ LSCREN,ISMX2D,ISMX3D,UNCOM C CHARACTER VARIABLES CHARACTER*79 LINE CHARACTER*8 CNUM8 CHARACTER*6 CNUM6 CHARACTER*7 PARNM(176) CHARACTER*3 UNK,FORB(44) CHARACTER*1 INPT(6),LET1(46),LET2(52) DATA LET1 / & 'B','C','D','E','F','G','H', & 'O','P','Q','R','S','U','V','W','Y','Z', & 'b','c','d','e','f','g','h', & 'o','p','q','r','s','u','v','w','y','z', & 'I','J','K','L','M','N','i','j','k','l','m','n'/ DATA LET2 / 'A','B','C','D','E','F','G','H','O','P', & 'Q','R','S','T','U','V','W','X','Y','Z', & 'a','b','c','d','e','f','g','h','o','p', & 'q','r','s','t','u','v','w','x','y','z', & 'I','J','K','L','M','N','i','j','k','l','m','n'/ DATA FORB/ & 'A1 ','A2 ','A3 ','A4 ','A5 ','A6 ','A7 ','A8 ','A9 ','PI ','pI', & 'a1 ','a2 ','a3 ','a4 ','a5 ','a6 ','a7 ','a8 ','a9 ','Pi ','pi', & 'NX ','DT ','TF ','XA ','XB ','T0 ', & 'Nx ','Dt ','Tf ','Xa ','Xb ','t0 ', & 'nX ','dT ','tF ','xA ','xB ', & 'nx ','dt ','tf ','xa ','xb '/ INF = 10000 CALL COM (2,'*** 1D PROBLEM SOLVED (GALERKIN METHOD) ***') CALL MESS (0,7) CALL IFYES (DP) CALL PREC WRITE (LUN,120) NEQNMX WRITE (LUN,125) NDELMX LUN = LFORT CALL TEXT ('dimension xgrid(nxgrid),ixarc(2),'// & 'xout8z(0:nx),xcross(100),tout8z(0:nsave)') CALL COM (2,' dimension xres8z(nxp8z),ures8z(neqn,nxp8z)') CALL TEXT ('allocatable iwrk8z(:),rwrk8z(:)') CALL COM (2,' dimension iwrk8z(iiwk8z),rwrk8z(irwk8z)') CALL TEXT ('character*40 title') CALL TEXT ('logical plot,symm,fdiff,evcmpx,crankn,fixl,fixr,'// & 'noupdt,adapt,econ8z,ncon8z,restrt,gridid') IF (DP) THEN CALL TEXT & ('common/dtdp14/ sint8z(20),bint8z(20),slim8z(20),blim8z(20)') CALL TEXT ('common/dtdp15/ evlr8z,ev0r,evli8z,ev0i,evcmpx') CALL TEXT ('common/dtdp16/ p8z,evr8z(50),evi8z(50)') CALL TEXT ('common/dtdp19/ toler(neqnmx),adapt') CALL TEXT ('common/dtdp20/ xd0(ndelmx),ndel,idel8z,jdel8z') CALL TEXT ('common/dtdp30/ econ8z,ncon8z') CALL TEXT ('common/dtdp42/ nxa8z,kd8z') CALL TEXT ('common/dtdp43/ work8z(nxp8z+3)') CALL TEXT ('common/dtdp46/ eps8z,cgtl8z,npmx8z,itype,near8z') CALL TEXT ('common/dtdp62/ amin8z(2*neqnmx),amax8z(2*neqnmx)') CALL TEXT & ('common/dtdp75/ nx18z,xa,xb,uout(0:nx,2,neqn,0:nsave)') ELSE CALL TEXT & ('common/ tdp14/ sint8z(20),bint8z(20),slim8z(20),blim8z(20)') CALL TEXT ('common/ tdp15/ evlr8z,ev0r,evli8z,ev0i,evcmpx') CALL TEXT ('common/ tdp16/ p8z,evr8z(50),evi8z(50)') CALL TEXT ('common/ tdp19/ toler(neqnmx),adapt') CALL TEXT ('common/ tdp20/ xd0(ndelmx),ndel,idel8z,jdel8z') CALL TEXT ('common/ tdp30/ econ8z,ncon8z') CALL TEXT ('common/ tdp42/ nxa8z,kd8z') CALL TEXT ('common/ tdp43/ work8z(nxp8z+3)') CALL TEXT ('common/ tdp46/ eps8z,cgtl8z,npmx8z,itype,near8z') CALL TEXT ('common/ tdp62/ amin8z(2*neqnmx),amax8z(2*neqnmx)') CALL TEXT & ('common/ tdp75/ nx18z,xa,xb,uout(0:nx,2,neqn,0:nsave)') ENDIF CALL TEXT ('pi = 4.0*atan(1.d0)') CALL TEXT ('nxa8z = nxp8z') CALL TEXT ('nx18z = nx+1') CALL TEXT ('kd8z = kdeg8z') CALL MESS (0,8) CALL TEXT ('NPROB = 1') CALL INVAR ('NPROB',.FALSE.) CALL STATE (IST999) WRITE (LUN,5) IST999 5 FORMAT (6X,'do ',I5,' iprob=1,nprob') CALL MESS (0,62) CALL GLOBP(LET1,46,LET2,52,FORB,44,PARNM,NPARN) CALL MESS (1,10) CALL IFYES (YES) LEVEL = 2 IF (YES) LEVEL = 3 C INITIAL TRIANGULATION ON RECTANGULAR GRID LUN = LFORT C RECTANGULAR GRID CALL MESS (0,63) IF (DP) THEN CALL TEXT ('call dtdpwx(xgrid,nxgrid,0)') ELSE CALL TEXT ('call tdpwx(xgrid,nxgrid,0)') ENDIF LUN = LPARAM CALL COM (1,'NXGRID = number of X-grid lines') CALL INPARM ('NXGRID', NXGRID, 3, INF) LUN = LFORT CALL COM (2, ' XGRID DEFINED') CALL INVAR ('XGRID(1)', .TRUE.) CALL INVEC ('XGRID', 2, NXGRID-1, .FALSE.) CALL INVAR ('XGRID(NXGRID)', .TRUE.) IF (DP) THEN CALL TEXT ('call dtdpwx(xgrid,nxgrid,1)') ELSE CALL TEXT ('call tdpwx(xgrid,nxgrid,1)') ENDIF CALL MESS (0,64) CALL IREAD ('IDEG', IDEG, 1, 4) C IDENTIFY TYPE OF PDE CALL MESS (1,11) CALL IREAD (' ', ITYPE, 1, 3) ELL = ITYPE .EQ. 1 PARA = ITYPE .EQ. 2 EIGEN = ITYPE .EQ. 3 IF (EIGEN) THEN C EIGENVALUE PROBLEM SOLVED CALL COM (2, ' *******EIGENVALUE PROBLEM') CALL MESS (0,12) CALL PAWS CALL TEXT ('ITYPE = 3') CALL COM (2,' ') CALL COM (2,' P8Z = 0.0') LINEAR = .TRUE. CALL TEXT ('t0 = 0.0') CALL TEXT ('dt = 1.0') CALL TEXT ('crankn = .false.') CALL TEXT ('noupdt = .true.') CALL MESS (0,13) CALL IFYES (EVCMPX) IF (.NOT.EVCMPX) THEN CALL TEXT ('EVCMPX = .FALSE.') CALL MESS (0,14) CALL TEXT ('EV0R = 0.0') CALL INVAR ('EV0R', .FALSE.) ELSE CALL TEXT ('EVCMPX = .TRUE.') CALL MESS (0,15) CALL TEXT ('EV0R = 0.0') CALL TEXT ('EV0I = 0.0') CALL INVAR ('EV0R', .FALSE.) CALL INVAR ('EV0I', .FALSE.) ENDIF CALL MESS (0,16) CALL TEXT ('NSTEPS = 25') CALL INVAR ('NSTEPS',.FALSE.) ELSE IF (PARA) THEN C TIME DEPENDENT PROBLEM SOLVED CALL COM (2, ' *******TIME-DEPENDENT PROBLEM') CALL TEXT ('itype = 2') CALL MESS (0,17) CALL TEXT ('T0 = 0.0') CALL INVAR ('T0', .FALSE.) CALL INVAR ('TF', .TRUE.) CALL MESS (1,18) CALL IFYES (LINEAR) CALL MESS (0,19) CALL IFYES (YES) IF (YES) THEN CALL TEXT ('ADAPT = .TRUE.') CALL TEXT ('TOLER(1) = 0.01') CALL INVAR ('TOLER(1)', .FALSE.) IF (LINEAR) CALL MESS (2,20) CALL TEXT ('NOUPDT = .FALSE.') CALL MESS (0,21) ELSE CALL TEXT ('ADAPT = .FALSE.') CALL TEXT ('TOLER(1) = 0.01') IF (LINEAR) THEN CALL MESS (0,20) CALL IFYES (YES) IF (YES) THEN CALL TEXT ('NOUPDT = .TRUE.') ELSE CALL TEXT ('NOUPDT = .FALSE.') ENDIF ELSE CALL TEXT ('NOUPDT = .FALSE.') ENDIF CALL MESS (0,22) ENDIF CALL INVAR ('NSTEPS',.TRUE.) CALL TEXT ('dt = (tf-t0)/max(nsteps,1)') CALL MESS (0,65) CALL IFYES (YES) IF (YES) THEN CALL TEXT ('CRANKN = .TRUE.') ELSE CALL TEXT ('CRANKN = .FALSE.') ENDIF ELSE C STEADY STATE PROBLEM SOLVED CALL COM (2, ' *******STEADY-STATE PROBLEM') CALL TEXT ('itype = 1') CALL TEXT ('t0 = 0.0') CALL TEXT ('dt = 1.0') CALL TEXT ('crankn = .false.') CALL TEXT ('noupdt = .false.') CALL MESS (1,18) CALL IFYES (LINEAR) IF (LINEAR) THEN CALL COM (2, ' Number of Newton iterations') CALL TEXT ('NSTEPS = 1') ELSE CALL MESS (0,24) CALL TEXT ('NSTEPS = 15') CALL INVAR ('NSTEPS',.FALSE.) ENDIF ENDIF LUN = LPARAM CALL MESS (0,25) CALL INPARM ('NEQN', NEQN, 1, NEQNMX) LUN = LFORT CALL MESS (1,66) CALL VARNAM(LET1,34,LET2,40,FORB,22,NEQN) IND = MIN(NEQN-1,3) C SYMMETRIC? IF (EIGEN) THEN CALL MESS (0,67) ELSE IF (ELL) THEN CALL MESS (0,68) ELSE IF (PARA) THEN CALL MESS (0,69) ENDIF CALL IFYES (SYMM) IF (SYMM) THEN CALL TEXT ('SYMM = .TRUE.') ELSE CALL TEXT ('SYMM = .FALSE.') ENDIF C FINITE DIFFERENCE JACOBIAN? IF (LINEAR) THEN FDIFF = .FALSE. ELSE CALL MESS (0,27) CALL IFYES (FDIFF) ENDIF IF (FDIFF) THEN CALL TEXT ('FDIFF = .TRUE.') ELSE CALL TEXT ('FDIFF = .FALSE.') ENDIF C CALCULATE STORAGE REQUIREMENTS LUN = LPARAM CALL COM (2, ' DIMENSIONS OF WORK ARRAYS') IRWK = 1 IIWK = 1 CALL COM (2, ' SET TO 1 FOR AUTOMATIC ALLOCATION') WRITE (LUN,110) IRWK,IIWK 110 FORMAT (6X,'PARAMETER (IRWK8Z=',I12,')',/, 6X,'PARAMETER (IIWK8Z=' &,I12,')') CALL TEXT ('PARAMETER (NXP8Z=1001,KDEG8Z=1)') C SUBROUTINE PDES8Z LUN = LFUNS CALL TEXT (' ') CALL TEXT (' ') CALL TEXT ('subroutine pdes8z (yd8z,i8z,j8z,kint8z,x,t)') CALL PREC WRITE (LUN,120) NEQNMX 120 FORMAT (6X,'parameter (neqnmx=',I4,')') IF (EIGEN) WRITE (LUN,121) NEQN 121 FORMAT (6X,'parameter (NEQN=',I4,')') WRITE (LUN,125) NDELMX 125 FORMAT (6X,'parameter (ndelmx=',I4,')') CALL COM (2, ' un8z(1,I),un8z(2,I) hold'// & ' the (rarely used) values') CALL COM (2, ' of UI,UIx from the previous'// & ' iteration or time step') IF (DP) THEN CALL TEXT ('common/dtdp48/un8z(2,neqnmx),uu8z(2,neqnmx)') CALL TEXT ('common/dtdp11/normx') CALL TEXT ('common/dtdp20/xd0(ndelmx),ndel,idel8z,jdel8z') CALL TEXT('double precision normx,delamp(ndelmx,neqnmx)') ELSE CALL TEXT ('common/ tdp48/un8z(2,neqnmx),uu8z(2,neqnmx)') CALL TEXT ('common/ tdp11/normx') CALL TEXT ('common/ tdp20/xd0(ndelmx),ndel,idel8z,jdel8z') CALL TEXT('real normx,delamp(ndelmx,neqnmx)') ENDIF IF (EIGEN.AND.(NEQN.GT.1)) CALL TEXT('dimension rho(neqn,neqn)') WRITE (LUN,535) (PARNM(I),I=1,NPARN) DO 160 IEQ = 1,NEQN WRITE (LUN,130) UNK(IEQ)(1:NUNK(IEQ)),IEQ 130 FORMAT(6X,A,' = uu8z(1,',I2,')') WRITE (LUN,140) UNK(IEQ)(1:NUNK(IEQ)),IEQ 140 FORMAT(6X,A,'x = uu8z(2,',I2,')') 160 CONTINUE CALL TEXT (' if (i8z.eq.0) then') CALL TEXT ('yd8z = 0.0') LUN = LFORT CALL MESS (0,28) CALL IREAD ('NINT', NINT, 0, 20) LUN = LFUNS IF (NINT.GT.0) THEN CALL MESS (0,70 + IND) CALL IADD (3, 'the integrals') DO 170 I=1,NINT CALL VECFUN('INTEGRAL',I,NINT,I,'yd8z',0,'kint8z') 170 CONTINUE ELSE CALL MESS (2,70 + IND) WRITE (LUN,180) 180 FORMAT ('C',50X,'INTEGRAL1 DEFINED',/, & 'C if (kint8z.eq.1) yd8z =',/, & 'C & [DEFAULT SELECTED, DEFINITION COMMENTED OUT]') ENDIF LUN = LFORT CALL MESS (0,74) CALL IREAD ('NBINT', NBINT, 0, 20) LUN = LFUNS IF (NBINT.GT.0) THEN CALL MESS (0,75 + IND) CALL IADD (3, 'the boundary integrals') DO 190 I=1,NBINT CALL VECFUN('BND. INTEGRAL',I,NBINT,(-I),'yd8z',0,'kint8z') 190 CONTINUE ELSE CALL MESS (2,75 + IND) WRITE (LUN,200) 200 FORMAT ('C',50X,'BND. INTEGRAL1 DEFINED',/, & 'C if (kint8z.eq.-1) yd8z =',/, & 'C & [DEFAULT SELECTED, DEFINITION COMMENTED OUT]') ENDIF LUN = LFORT IF (.NOT.EIGEN) THEN CALL MESS (1,79) CALL IFYES(YES) IF (YES) THEN CALL MESS (0,80) CALL IREAD ('NDEL', NDEL, 1, NDELMX) DO 210 I=1,NDEL CALL INVEC ('XD0', I, I, .TRUE.) 210 CONTINUE LUN = LFUNS CALL TEXT (' if (kint8z.eq.0) then') CALL MESS (0,81) CALL IADD (3, 'the Delta function amplitudes') CALL INMAT ('DELAMP', 1, NDEL, 1, NEQN, .TRUE.) CALL TEXT ('yd8z = delamp(idel8z,jdel8z)') CALL TEXT (' endif') ELSE CALL TEXT ('ndel = 0') ENDIF ELSE CALL TEXT ('ndel = 0') ENDIF LUN = LFUNS CALL TEXT (' else') IF (EIGEN) THEN CALL MESS (0,82 + IND) CALL IADD (2, 'these coefficients') ELSE IF (ELL) THEN CALL MESS (0,86 + IND) CALL IADD (2, 'these coefficients') ELSE IF (PARA) THEN CALL MESS (0,90 + IND) CALL IADD (2, 'these coefficients') ENDIF CALL TEXT (' if (j8z.eq.0) then') CALL TEXT ('yd8z = 0.0') C PDES DEFINED DO 220 I = 1,NEQN II = 2*(I-1) IF (PARA) THEN DO 215 J = 1,NEQN LL = 100*I+J IF (NEQN.EQ.1) THEN CALL VECFUN ('C',1,1,(-LL),'yd8z',2,'i8z') ELSE IF (NEQN.LE.9) THEN WRITE (CNUM6,213) I,J 213 FORMAT ('C(',I1,',',I1,')') CALL VECFUN (CNUM6,1,1,(-LL),'yd8z',2,'i8z') ELSE WRITE (CNUM8,214) I,J 214 FORMAT ('C(',I2,',',I2,')') CALL VECFUN (CNUM8,1,1,(-LL),'yd8z',2,'i8z') ENDIF 215 CONTINUE ENDIF CALL VECFUN('F', I, NEQN, II+1, 'yd8z', 2,'i8z') CALL VECFUN('A', I, NEQN, II+2, 'yd8z', 2,'i8z') IF (EIGEN) THEN IF (NEQN .EQ. 1) THEN CALL COM (2, & ' RHO DEFINED') CALL INVAR ('RHO', .TRUE.) ELSE CALL COM (2, & ' RHO DEFINED') CALL INMAT ('RHO', I, I, 1, NEQN, .TRUE.) ENDIF ENDIF 220 CONTINUE IF (EIGEN) THEN IF (DP) THEN CALL TEXT ('call dtdpza (yd8z,i8z,uu8z,un8z,rho,2,neqn)') ELSE CALL TEXT ('call tdpza (yd8z,i8z,uu8z,un8z,rho,2,neqn)') ENDIF ENDIF CALL TEXT (' else') IF ( .NOT.LINEAR .AND. .NOT.FDIFF) THEN DO 240 I = 1,NEQN DO 230 J = 1,NEQN II = 2*(I-1) JJ = 2*(J-1) CALL MATFUN('F', I, NEQN, UNK(J)(1:NUNK(J)), & II + 1, JJ + 1, 'yd8z', 0) CALL MATFUN('F', I, NEQN, UNK(J)(1:NUNK(J))//'x', & II + 1, JJ + 2, 'yd8z', 0) CALL MATFUN('A', I, NEQN, UNK(J)(1:NUNK(J)), & II + 2, JJ + 1, 'yd8z', 0) CALL MATFUN('A', I, NEQN, UNK(J)(1:NUNK(J))//'x', & II + 2, JJ + 2, 'yd8z', 0) 230 CONTINUE 240 CONTINUE ENDIF CALL TEXT (' endif') CALL TEXT (' endif') CALL TEXT ('return') CALL TEXT ('end') C INITIAL VALUES SPECIFIED CALL TEXT (' ') CALL TEXT (' ') CALL TEXT ('function u8z(i8z,x,t0)') CALL PREC WRITE (LUN,535) (PARNM(I),I=1,NPARN) IF (EIGEN) THEN IF (DP) THEN CALL TEXT ('u8z = dtdpxx()') ELSE CALL TEXT ('u8z = tdpxx()') ENDIF ELSE CALL TEXT ('u8z = 0.0') ENDIF IF ( .NOT.ELL .OR. .NOT.LINEAR) THEN IF (EIGEN) CALL MESS (0,94) IF (ELL) CALL MESS (0,95) IF (PARA) CALL MESS (0,96) CALL IADD (3, 'the initial values') DO 250 I = 1,NEQN IF (EIGEN) THEN CALL VECFUN (UNK(I)(1:NUNK(I))//'0',0,1,I, & 'u8z',1,'i8z') ELSE CALL VECFUN (UNK(I)(1:NUNK(I))//'0',0,1,I, & 'u8z',2,'i8z') ENDIF 250 CONTINUE LUN = LFORT CALL MESS (0,48) CALL IFYES(RESTRT) IF (RESTRT) THEN CALL TEXT ('RESTRT = .TRUE.') CALL MESS (0,97) CALL IFYES(YES) IF (YES) THEN CALL TEXT ('GRIDID = .TRUE.') ELSE CALL TEXT ('GRIDID = .FALSE.') ENDIF ELSE CALL TEXT ('RESTRT = .FALSE.') CALL COM (2,'GRIDID = .FALSE. IF FINITE ELEMENT'// & ' GRID CHANGES BETWEEN DUMP, RESTART') CALL TEXT ('GRIDID = .TRUE.') ENDIF ELSE LUN = LFORT CALL TEXT ('RESTRT = .FALSE.') CALL TEXT ('GRIDID = .TRUE.') ENDIF LUN = LFUNS CALL TEXT ('return') CALL TEXT ('end') LUN = LFORT CALL MESS (0,98) CALL IFYES (FIXL) IF (FIXL) THEN CALL TEXT ('FIXL = .TRUE.') ELSE CALL TEXT ('FIXL = .FALSE.') ENDIF CALL COM (2,' ') CALL TEXT ('ixarc(1) = 1') CALL TEXT ('if (fixl) ixarc(1) = -1') CALL MESS (0,99) CALL IFYES (FIXR) IF (FIXR) THEN CALL TEXT ('FIXR = .TRUE.') ELSE CALL TEXT ('FIXR = .FALSE.') ENDIF CALL COM (2,' ') CALL TEXT ('ixarc(2) = 2') CALL TEXT ('if (fixr) ixarc(2) = -2') LUN = LFUNS C FIXED BOUNDARY CONDITIONS DEFINED CALL TEXT (' ') CALL TEXT (' ') CALL TEXT ('function fb8z(i8z,iarc8z,x,t)') CALL PREC WRITE (LUN,535) (PARNM(I),I=1,NPARN) CALL TEXT ('fb8z = 0.0') IF (EIGEN) THEN CALL MESS (0,100) CALL PAWS ELSE CALL TEXT (' if (iarc8z.eq.-1) then') IF (FIXL) THEN CALL MESS (0,101) CALL MESS (0,102 + IND) CALL IADD & (3, 'the boundary conditions (left endpoint only)') IDEF = 2 ELSE CALL COM (2, & ' FIXL=.FALSE., SO NO FIXED BCs AT LEFT ENDPOINT.') CALL COM (2, & ' IF FIXL CHANGED TO .TRUE., USE MODEL BELOW TO DEFINE BCs') CALL MESS (2,102 + IND) IDEF = 3 ENDIF DO 270 I = 1,NEQN CALL VECFUN ('FB', I, NEQN, I, 'fb8z', IDEF, 'i8z') 270 CONTINUE CALL TEXT (' endif') CALL TEXT (' if (iarc8z.eq.-2) then') IF (FIXR) THEN CALL MESS (0,106) CALL MESS (0,102 + IND) CALL IADD & (3, 'the boundary conditions (right endpoint only)') IDEF = 2 ELSE CALL COM (2, & ' FIXR=.FALSE., SO NO FIXED BCs AT RIGHT ENDPOINT.') CALL COM (2, & ' IF FIXR CHANGED TO .TRUE., USE MODEL BELOW TO DEFINE BCs') CALL MESS (2,102 + IND) IDEF = 3 ENDIF DO 275 I = 1,NEQN CALL VECFUN ('FB', I, NEQN, I, 'fb8z', IDEF, 'i8z') 275 CONTINUE CALL TEXT (' endif') ENDIF CALL TEXT ('return') CALL TEXT ('end') C FREE BOUNDARY CONDITIONS DEFINED CALL TEXT (' ') CALL TEXT (' ') CALL TEXT & ('subroutine gb8z(gd8z,i8z,j8z,iarc8z,x,t)') CALL PREC WRITE (LUN,120) NEQNMX CALL COM (2, ' un8z(1,I),un8z(2,I) hold'// & ' the (rarely used) values') CALL COM (2, ' of UI,UIx from the previous'// & ' iteration or time step.') IF (DP) THEN CALL TEXT ('common/dtdp48/un8z(2,neqnmx),uu8z(2,neqnmx)') CALL TEXT ('common/dtdp49/bign8z') ELSE CALL TEXT ('common/ tdp48/un8z(2,neqnmx),uu8z(2,neqnmx)') CALL TEXT ('common/ tdp49/bign8z') ENDIF WRITE (LUN,535) (PARNM(I),I=1,NPARN) CALL TEXT ('zero(f8z) = bign8z*f8z') DO 290 IEQ = 1,NEQN WRITE (LUN,130) UNK(IEQ)(1:NUNK(IEQ)),IEQ WRITE (LUN,140) UNK(IEQ)(1:NUNK(IEQ)),IEQ 290 CONTINUE CALL TEXT ('if (j8z.eq.0) gd8z = 0.0') CALL TEXT (' if (iarc8z.eq.1) then') IF (.NOT.FIXL) THEN CALL MESS (0,101) CALL PAWS CALL MESS (0,107 + IND) CALL IADD (3, 'the boundary conditions (left endpoint only)') IDEF = 2 JDEF = 0 ELSE CALL COM (2, & ' FIXL=.TRUE., SO NO FREE BCs AT LEFT ENDPOINT.') CALL COM (2, & ' IF FIXL CHANGED TO .FALSE., USE MODEL BELOW TO DEFINE BCs') CALL MESS (2,107 + IND) IDEF = 3 JDEF = 1 ENDIF CALL TEXT (' if (j8z.eq.0) then') DO 310 I = 1,NEQN CALL VECFUN ('GB', I, NEQN, I, 'gd8z', IDEF, 'i8z') 310 CONTINUE CALL TEXT (' else') IF ( .NOT.LINEAR .AND. .NOT.FDIFF) THEN DO 330 I = 1,NEQN DO 320 J = 1,NEQN CALL MATFUN ('GB', I, NEQN, UNK(J)(1:NUNK(J)), & I, J, 'gd8z', JDEF) CALL MATFUN ('GB', I, NEQN, UNK(J)(1:NUNK(J))//'x', & I, 100+J, 'gd8z', JDEF) 320 CONTINUE 330 CONTINUE ENDIF CALL TEXT (' endif') CALL TEXT (' endif') CALL TEXT (' if (iarc8z.eq.2) then') IF (.NOT.FIXR) THEN CALL MESS (0,106) CALL PAWS CALL MESS (0,107 + IND) CALL IADD (3, 'the boundary conditions (right endpoint only)') IDEF = 2 JDEF = 0 ELSE CALL COM (2, & ' FIXR=.TRUE., SO NO FREE BCs AT RIGHT ENDPOINT.') CALL COM (2, & ' IF FIXR CHANGED TO .FALSE., USE MODEL BELOW TO DEFINE BCs') CALL MESS (2,107 + IND) IDEF = 3 JDEF = 1 ENDIF CALL TEXT (' if (j8z.eq.0) then') DO 315 I = 1,NEQN CALL VECFUN ('GB', I, NEQN, I, 'gd8z', IDEF, 'i8z') 315 CONTINUE CALL TEXT (' else') IF ( .NOT.LINEAR .AND. .NOT.FDIFF) THEN DO 335 I = 1,NEQN DO 325 J = 1,NEQN CALL MATFUN ('GB', I, NEQN, UNK(J)(1:NUNK(J)), & I, J, 'gd8z', JDEF) CALL MATFUN ('GB', I, NEQN, UNK(J)(1:NUNK(J))//'x', & I, 100+J, 'gd8z', JDEF) 325 CONTINUE 335 CONTINUE ENDIF CALL TEXT (' endif') CALL TEXT (' endif') C CALL TEXT ('return') CALL TEXT ('end') C OUTPUT MODIFICATION FUNCTIONS DEFINED LUN = LFUNS CALL TEXT (' ') CALL TEXT (' ') CALL TEXT ('subroutine pmod8z(x,t,a)') CALL PREC WRITE (LUN,120) NEQNMX IF (DP) THEN CALL TEXT ('common/dtdp48/un8z(2,neqnmx),uu8z(2,neqnmx)') CALL TEXT ('common/dtdp68/upr8z(2,neqnmx),uab8z(2,neqnmx)') CALL TEXT & ('common/dtdp9/uprint(neqnmx),aprint(neqnmx),bpr8z(neqnmx)') CALL TEXT & ('common/dtdp14/sint(20),bint(20),slim8z(20),blim8z(20)') ELSE CALL TEXT ('common/ tdp48/un8z(2,neqnmx),uu8z(2,neqnmx)') CALL TEXT ('common/ tdp68/upr8z(2,neqnmx),uab8z(2,neqnmx)') CALL TEXT & ('common/ tdp9/uprint(neqnmx),aprint(neqnmx),bpr8z(neqnmx)') CALL TEXT & ('common/ tdp14/sint(20),bint(20),slim8z(20),blim8z(20)') ENDIF WRITE (LUN,535) (PARNM(I),I=1,NPARN) DO 380 IEQ = 1,NEQN WRITE (LUN,130) UNK(IEQ)(1:NUNK(IEQ)),IEQ WRITE (LUN,140) UNK(IEQ)(1:NUNK(IEQ)),IEQ IF (IEQ.LE.9) THEN WRITE (LUN,340) IEQ, IEQ 340 FORMAT(6X,'a',I1,' = upr8z(2,',I2,')') ELSE WRITE (LUN,360) IEQ, IEQ 360 FORMAT(6X,'a',I2,' = upr8z(2,',I2,')') ENDIF 380 CONTINUE CALL MESS (0,111 + IND) CALL IADD (3, 'these variables') CALL COM (2, ' DEFINE UPRINT(*),APRINT(*) HERE:') DO 400 I=1,NEQN WRITE (INTOUT,381) UNK(I)(1:NUNK(I)) 381 FORMAT (' Replace ',A,' for postprocessing?') CALL INVEC ('UPRINT', I, I, .FALSE.) IF (NEQN.EQ.1) THEN WRITE (INTOUT,382) 382 FORMAT (' Replace A for postprocessing?') ELSE IF (I.LE.9) THEN WRITE (INTOUT,383) I 383 FORMAT (' Replace A',I1,' for postprocessing?') ELSE WRITE (INTOUT,384) I 384 FORMAT (' Replace A',I2,' for postprocessing?') ENDIF CALL INVEC ('APRINT', I, I, .FALSE.) 400 CONTINUE CALL TEXT ('return') CALL TEXT ('end') C OUTPUT PARAMETERS LUN = LPARAM CALL MESS (0,115) CALL IREAD (' ',NX,-INF,INF) IF (NX.LE.0) THEN WRITE (LUN,390) -NX 390 FORMAT (6X,'PARAMETER (NX = ',I10,')') LUN = LFORT CALL TEXT ('npts8z = nx+1') CALL MESS (0,116) CALL IADD (0, ' ') ELSE WRITE (LUN,390) NX LUN = LFORT CALL MESS (0,117) CALL COM (2,' defaults for xa,xb') CALL TEXT ('xa = xgrid(1)') CALL TEXT ('xb = xgrid(nxgrid)') CALL COM (2,' DEFINE XA,XB IMMEDIATELY BELOW:') CALL INVAR ('XA',.FALSE.) CALL INVAR ('XB',.FALSE.) IF (DP) THEN CALL TEXT ('call dtdpx1(nx,xa,xb,hx8z,xout8z,npts8z)') ELSE CALL TEXT ('call tdpx1(nx,xa,xb,hx8z,xout8z,npts8z)') ENDIF ENDIF IF (PARA) THEN LUN = LPARAM CALL MESS (0,53) CALL INPARM ('NSAVE', NSAVE, 1, INF) LUN = LFORT ELSE LUN = LPARAM NSAVE = 1 CALL TEXT ('PARAMETER (NSAVE = 1)') LUN = LFORT CALL COM (2, ' SOLUTION SAVED EVERY NOUT ITERATIONS') CALL TEXT ('NOUT = NSTEPS') ENDIF IF (DP) THEN CALL TEXT ('call dtdpzg(nxgrid,ideg,symm,neqn,'// & 'ii8z,ir8z)') ELSE CALL TEXT ('call tdpzg(nxgrid,ideg,symm,neqn,'// & 'ii8z,ir8z)') ENDIF CALL TEXT ('if (iiwk8z.gt.1) ii8z = iiwk8z') CALL TEXT ('if (irwk8z.gt.1) ir8z = irwk8z') CALL COM (2, ' *******allocate workspace') CALL TEXT ('allocate (iwrk8z(ii8z),rwrk8z(ir8z))') CALL COM (2,' *******DRAW GRID POINTS?') CALL TEXT ('PLOT = .TRUE.') CALL COM (2, ' *******call pde solver') IF (DP) THEN CALL TEXT ('call dtdpgx(xgrid, nxgrid, ixarc,'// & ' restrt, gridid, neqn, ideg, nsteps, nout, t0, dt,'// & ' plot, symm, fdiff, itype, nint, nbint,'// & ' crankn, noupdt, xout8z, uout, npts8z, tout8z,'// & ' nsave, iwrk8z, ii8z, rwrk8z, ir8z)') ELSE CALL TEXT ('call tdpgx(xgrid, nxgrid, ixarc,'// & ' restrt, gridid, neqn, ideg, nsteps, nout, t0, dt,'// & ' plot, symm, fdiff, itype, nint, nbint,'// & ' crankn, noupdt, xout8z, uout, npts8z, tout8z,'// & ' nsave, iwrk8z, ii8z, rwrk8z, ir8z)') ENDIF CALL TEXT ('deallocate (iwrk8z,rwrk8z)') IF (EIGEN) THEN WRITE (LUN,401) IST999 401 FORMAT (6X,'if (itype.eq.4) go to ',I5) CALL COM (2, & ' *******UNCOMMENT TO POSTPROCESS ONLY IF CONVERGED') WRITE (LUN,405) IST999 405 FORMAT ('C',6X,'IF (.NOT.ECON8Z) GO TO ',I5) ENDIF IF (ELL.AND.(.NOT.LINEAR)) THEN CALL COM (2, & ' *******UNCOMMENT TO POSTPROCESS ONLY IF CONVERGED') WRITE (LUN,406) IST999 406 FORMAT ('C',6X,'IF (.NOT.NCON8Z) GO TO ',I5) ENDIF IF (DP) THEN CALL COM (2, & ' *******read from restart file to array ures8z') CALL COM (2,' call dtdpr1(1,xres8z,nxp8z,ures8z,neqn)') CALL COM (2, & ' *******write array ures8z back to restart file') CALL COM (2,' call dtdpr1(2,xres8z,nxp8z,ures8z,neqn)') ELSE CALL COM (2, & ' *******read from restart file to array ures8z') CALL COM (2,' call tdpr1(1,xres8z,nxp8z,ures8z,neqn)') CALL COM (2, & ' *******write array ures8z back to restart file') CALL COM (2,' call tdpr1(2,xres8z,nxp8z,ures8z,neqn)') ENDIF CALL COM (2,' *******call user-written postprocessor') CALL TEXT ('call postpr(tout8z,nsave,xout8z,nx,uout,neqn)') 410 CONTINUE CALL MESS (1,118) IPLIM = 3 IF (.NOT.PARA) IPLIM = 2 CALL IREAD (' ',IPLOT,0,IPLIM) IF (IPLOT .EQ. 0) THEN GO TO 440 ELSE IF (IPLOT .EQ. 1) THEN C TABLE OF VALUES AT OUTPUT POINTS CALL COM (2,' *******TABULAR OUTPUT') CALL MESS (0,119 + IND) CALL IREAD ('IVAR',IVAR,1,2*NEQN) CALL TEXT ('ivara8z = mod(ivar-1,2)+1') CALL TEXT ('ivarb8z = (ivar-1)/2+1') IF (.NOT.PARA) THEN CALL TEXT ('ISET1 = 1') CALL TEXT ('ISET2 = NSAVE') CALL TEXT ('ISINC = 1') ELSE CALL MESS (0,123) CALL TEXT ('ISET1 = 0') CALL TEXT ('ISET2 = NSAVE') CALL TEXT ('ISINC = 1') CALL INVAR ('ISET1',.FALSE.) CALL INVAR ('ISET2',.FALSE.) CALL INVAR ('ISINC',.FALSE.) ENDIF CALL MESS (0,59) CALL TEXT ('TITLE = '' '' ') CALL INSTR ('TITLE',.FALSE.) CALL STATE (ISTAT) IF (DP) THEN CALL TEXT('call dtdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,590) ISTAT CALL TEXT ('call dtdp1d(xout8z,'// & 'uout(0,ivara8z,ivarb8z,is8z),npts8z,title,tout8z(is8z))') ELSE CALL TEXT('call tdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,590) ISTAT CALL TEXT ('call tdp1d(xout8z,'// & 'uout(0,ivara8z,ivarb8z,is8z),npts8z,title,tout8z(is8z))') ENDIF WRITE (LUN,610) ISTAT ELSE IF (IPLOT .EQ. 2) THEN C LINE PLOTS CALL COM (2, ' *******LINE PLOTS') CALL MESS (0,119 + IND) CALL IREAD ('IVAR', IVAR, 1, 2*NEQN) CALL MESS (1,124) ICSLIM = 2 IF (.NOT.PARA) ICSLIM = 1 CALL IREAD (' ', ICS, 1, ICSLIM) IF (ICS.EQ.1) THEN CALL COM (2, ' X IS VARIABLE') CALL TEXT ('ics8z = 1') ELSE IF (ICS.EQ.2) THEN CALL COM (2, ' T IS VARIABLE') CALL TEXT ('ics8z = 2') CALL MESS (0,125) CALL IREAD ('NXVALS', NXVALS, 1, 100) CALL INVEC ('XCROSS', 1, NXVALS, .TRUE.) ENDIF IF (ICS.EQ.1) THEN IF (.NOT.PARA) THEN CALL TEXT ('ISET1 = 1') CALL TEXT ('ISET2 = NSAVE') CALL TEXT ('ISINC = 1') ELSE CALL MESS (0,123) CALL TEXT ('ISET1 = 0') CALL TEXT ('ISET2 = NSAVE') CALL TEXT ('ISINC = 1') CALL INVAR ('ISET1',.FALSE.) CALL INVAR ('ISET2',.FALSE.) CALL INVAR ('ISINC',.FALSE.) ENDIF ENDIF CALL COM (2,' ') CALL TEXT ('alow = amin8z(ivar)') CALL TEXT ('ahigh = amax8z(ivar)') CALL MESS (0,126) CALL TEXT ('UMIN = 0.0') CALL TEXT ('UMAX = 0.0') CALL INVAR ('UMIN', .FALSE.) CALL INVAR ('UMAX', .FALSE.) CALL MESS (0,59) CALL TEXT ('TITLE = '' '' ') CALL INSTR ('TITLE',.FALSE.) CALL STATE (ISTAT) IF (DP) THEN IF (ICS.EQ.1) THEN CALL TEXT('call dtdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,590) ISTAT ELSE IF (ICS.EQ.2) THEN CALL TEXT ('is8z = 0') WRITE (LUN,430) ISTAT CALL TEXT ('call dtdpzy(xcross(ixv8z),xout8z,nx,ix8z)') ENDIF CALL TEXT ('call dtdpzp(ics8z,ivar,tout8z,nsave,'// & 'xout8z,nx,uout,neqn,title,umin,umax,ix8z,is8z)') ELSE IF (ICS.EQ.1) THEN CALL TEXT('call tdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,590) ISTAT ELSE IF (ICS.EQ.2) THEN CALL TEXT ('is8z = 0') WRITE (LUN,430) ISTAT CALL TEXT ('call tdpzy(xcross(ixv8z),xout8z,nx,ix8z)') ENDIF CALL TEXT ('call tdpzp(ics8z,ivar,tout8z,nsave,'// & 'xout8z,nx,uout,neqn,title,umin,umax,ix8z,is8z)') ENDIF WRITE (LUN,610) ISTAT ELSE IF (IPLOT.EQ.3) THEN C SURFACE PLOT CALL COM (2, ' *******SURFACE PLOT') CALL MESS (0,119 + IND) CALL IREAD ('IVAR', IVAR, 1, 2*NEQN) CALL MESS (0,127) CALL TEXT ('VLON = 45.0') CALL TEXT ('VLAT = 45.0') CALL INVAR ('VLAT', .FALSE.) CALL INVAR ('VLON', .FALSE.) CALL MESS (0,60) CALL TEXT ('UMIN = 0.0') CALL TEXT ('UMAX = 0.0') CALL INVAR ('UMIN', .FALSE.) CALL INVAR ('UMAX', .FALSE.) CALL MESS (0,59) CALL TEXT ('TITLE = '' '' ') CALL INSTR ('TITLE',.FALSE.) IF (DP) THEN CALL TEXT ('call dtdpzd(xout8z,tout8z,uout,nx,'// & 'nsave,title,neqn,ivar,vlon,vlat,umin,umax)') ELSE CALL TEXT ('call tdpzd(xout8z,tout8z,uout,nx,'// & 'nsave,title,neqn,ivar,vlon,vlat,umin,umax)') ENDIF ENDIF GO TO 410 430 FORMAT (6X,'do ',I5,' ixv8z=1,nxvals') 440 CONTINUE C ADD DUMMY PDE2D FUNCTIONS LUN = LFUNS CALL COM (2,' dummy routines') CALL TEXT ('function axis8z(i8z,x,y,z,ical8z)') CALL PREC CALL TEXT ('axis8z = 0') CALL TEXT ('return') CALL TEXT ('end') CALL TEXT ('subroutine tran8z(p,q,x,y)') CALL PREC CALL TEXT ('return') CALL TEXT ('end') CALL TEXT ('subroutine xy8z(i8z,iarc8z,s,x,y,s0,sf)') CALL PREC CALL TEXT ('return') CALL TEXT ('end') CALL TEXT ('subroutine dis8z(x,y,ktri,triden,shape)') CALL PREC CALL TEXT ('return') CALL TEXT ('end') C WRITE POSTPR CALL TEXT (' ') CALL TEXT (' ') CALL TEXT ( & 'subroutine postpr(tout,nsave,xout,nx,uout,neqn)') CALL PREC CALL TEXT ('dimension xout(0:nx),tout(0:nsave)') CALL TEXT ('dimension uout(0:nx,2,neqn,0:nsave)') WRITE (LUN,535) (PARNM(I),I=1,NPARN) IF (DP) THEN CALL TEXT ('common /dtdp27/ itask,npes,icomm') CALL TEXT ('common /dtdp46/ eps8z,cgtl8z,npmx8z,itype,near8z') ELSE CALL TEXT ('common / tdp27/ itask,npes,icomm') CALL TEXT ('common / tdp46/ eps8z,cgtl8z,npmx8z,itype,near8z') ENDIF CALL TEXT ('data lun,lud/0,47/') CALL TEXT ('if (itask.gt.0) return') CALL COM (2,'UOUT(I,IDER,IEQ,L) = U_IEQ, if IDER=1') CALL COM (2,' A_IEQ, if IDER=2') CALL COM (2,' (possibly as modified by UPRINT,..)') CALL COM (2,' at the point XOUT(I)') CALL COM (2,' at time/iteration TOUT(L).') CALL COM (2,' ******* ADD POSTPROCESSING CODE HERE:') CALL COM (2,' IN THE EXAMPLE BELOW, MATLAB PLOTFILES pde2d.m,') CALL COM (2,' pde2d.rdm CREATED (REMOVE C! COMMENTS TO ACTIVATE)') CALL COM (3,' if (lun.eq.0) then') CALL COM (3,' lun = 46') CALL COM (3,' open (lun,file=''pde2d.m'')') CALL COM (3,' open (lud,file=''pde2d.rdm'')') CALL COM (3, & ' write (lun,*) ''fid = fopen(''''pde2d.rdm'''');''') CALL COM (3,' endif') CALL COM (3,' do 78753 l=0,nsave') IF (DP) THEN CALL COM (3,' if (tout(l).ne.dtdplx(2)) nsave0 = l') ELSE CALL COM (3,' if (tout(l).ne. tdplx(2)) nsave0 = l') ENDIF CALL COM (4,'78753 continue') CALL COM (3,' write (lud,78754) nsave0') CALL COM (3,' write (lud,78754) neqn') CALL COM (3,' write (lud,78754) nx') CALL COM (4,'78754 format (i8)') CALL COM (3,' do 78755 i=0,nx') CALL COM (3,' write (lud,78760) xout(i)') CALL COM (4,'78755 continue') CALL COM (3,' do 78759 l=0,nsave0') CALL COM (3,' write (lud,78760) tout(l)') CALL COM (3,' do 78758 ieq=1,neqn') CALL COM (3,' do 78757 ider=1,2') CALL COM (3,' do 78756 i=0,nx') CALL COM (3,' write (lud,78760) uout(i,ider,ieq,l)') CALL COM (4,'78756 continue') CALL COM (4,'78757 continue') CALL COM (4,'78758 continue') CALL COM (4,'78759 continue') CALL COM (4,'78760 format (e16.8)') CALL COM (2,' ******* WRITE pde2d.m ') CALL COM (3,' call mtdp1dg(itype,lun)') CALL TEXT ('return') CALL TEXT ('end') C ENTER USER-SUPPLIED FUNCTIONS CALL MESS (1,61) CALL IFYES (YES) IF (YES) CALL IADD (0, ' ') C CALL TDP1E/DTDP1E TO INTERPOLATE TABULAR OUTPUT CALL MESS (1,128) CALL IFYES (YES) IF (YES) THEN C 450 CONTINUE CALL MESS (1,129) 460 CONTINUE WRITE (INTOUT,470) 470 FORMAT (' Function name =') CALL READLN (INPT,6,NOMORE) IF (NOMORE) THEN WRITE (INTOUT,490) GO TO 460 ENDIF DO 480 I = 1,40 IF (INPT(1) .EQ. LET2(I)) GO TO 500 480 CONTINUE WRITE (INTOUT,490) 490 FORMAT ('|---- Illegal function name, re-enter in columns 1-6') GO TO 460 500 CONTINUE WRITE (LUN,510) INPT 510 FORMAT (//,6X,'function ',6A1,'(x)') CALL PREC CALL MESS (0,130) CALL INPARM ('NWORK',NWORK,5,INF) CALL TEXT ('dimension work(nwork)') CALL TEXT ('character*40 fname') IF (DP) THEN CALL TEXT ('data work(1) /0.0d0/') ELSE CALL TEXT ('data work(1) /0.0/') ENDIF CALL MESS (0,131) CALL INSTR ('FNAME',.TRUE.) CALL MESS (0,132) CALL TEXT ('ISET = 1') CALL INVAR ('ISET',.FALSE.) CALL MESS (0,133) CALL IREAD ('KDEG',KDEG,1,3) IF (DP) THEN WRITE (LUN,520) INPT 520 FORMAT (6X,6A1,' = dtdp1e(fname,iset,work,nwork,kdeg,x)') ELSE WRITE (LUN,530) INPT 530 FORMAT (6X,6A1,' = tdp1e(fname,iset,work,nwork,kdeg,x)') ENDIF CALL TEXT ('return') CALL TEXT ('end') CALL MESS (1,134) CALL IFYES (YES) IF (YES) GO TO 450 C ENDIF CALL MESS (1,411) LUN = LFORT WRITE (LUN,610) IST999 CALL TEXT ('call endgks') CALL TEXT ('stop') CALL TEXT ('end') LUN = LPARAM WRITE (LUN,535) (PARNM(I),I=1,NPARN) 535 FORMAT (6X,'common/parm8z/ pi',6A7,/,(5X,'&',9A7)) C CONCATENATE PARAMETERS FILE, MAIN PROGRAM, AND SUBPROGRAMS REWIND LFORT 540 CONTINUE READ (LFORT,550,END=560) LINE 550 FORMAT (A79) WRITE (LPARAM,550) LINE GO TO 540 560 CONTINUE REWIND LFUNS 570 CONTINUE READ (LFUNS,550,END=580) LINE WRITE (LPARAM,550) LINE GO TO 570 580 CONTINUE 590 FORMAT (6X,'do ',I5,' is8z=iset1,iset2,isinc') 610 FORMAT (I5,' continue') STOP END SUBROUTINE PDE1DC PARAMETER (NEQNMX=99) LOGICAL YES,PARA,ELL,EIGEN,LINEAR,NOMORE,EVCMPX,DP, & RESTRT,FDIFF,UNCOM COMMON /EXMP/ LEVEL,IEXMP,DP COMMON /LUNITS/ INTIN,INTOUT,LMESS,LUN,LPARAM,LFORT,LFUNS,INFIL & ,IECHO COMMON /UNKNWN/ NUNK(NEQNMX),UNK(NEQNMX) COMMON /PARMS/ LSCREN,ISMX2D,ISMX3D,UNCOM C CHARACTER VARIABLES CHARACTER*79 LINE CHARACTER*8 CNUM8 CHARACTER*7 PARNM(176) CHARACTER*6 CNUM6 CHARACTER*3 UNK,FORB(26) CHARACTER*1 INPT(6),LET1(48),LET2(52) DATA LET1 / & 'A','B','C','D','E','F','G','H','O','P','Q','R','S','U','V','W', & 'Y','Z','a','b','c','d','e','f','g','h','o','p','q','r','s','u', & 'v','w','y','z','I','J','K','L','M','N','i','j','k','l','m','n'/ DATA LET2 / 'A','B','C','D','E','F','G','H','O','P', & 'Q','R','S','T','U','V','W','X','Y','Z', & 'a','b','c','d','e','f','g','h','o','p', & 'q','r','s','t','u','v','w','x','y','z', & 'I','J','K','L','M','N','i','j','k','l','m','n'/ DATA FORB/ & 'PI ','Pi ','pI ','pi ', & 'NX ','Nx ','nX ','nx ','DT ','Dt ','dT ','dt ', & 'TF ','Tf ','tF ','tf ','XA ','Xa ','xA ','xa ', & 'XB ','Xb ','xB ','xb ','T0 ','t0 '/ C INF = 10000 CALL COM (2,'*** 1D PROBLEM SOLVED (COLLOCATION METHOD) ***') CALL MESS (0,7) CALL IFYES (DP) CALL PREC WRITE (LUN,90) NEQNMX LUN = LFORT CALL TEXT ('dimension xgrid(nxgrid),xout8z(0:nx),xcross(100),'// & 'tout8z(0:nsave)') CALL COM (2,' dimension xres8z(nxp8z),ures8z(neqn,nxp8z)') CALL TEXT ('allocatable iwrk8z(:),rwrk8z(:)') CALL COM (2,' dimension iwrk8z(iiwk8z),rwrk8z(irwk8z)') CALL TEXT ('character*40 title') CALL TEXT ('logical linear,crankn,noupdt,nodist,fillin,'// & 'evcmpx,adapt,plot,lsqfit,fdiff,econ8z,ncon8z,restrt,gridid') IF (DP) THEN CALL TEXT & ('common/dtdp14/ sint8z(20),bint8z(20),slim8z(20),blim8z(20)') CALL TEXT ('common/dtdp15/ evlr8z,ev0r,evli8z,ev0i,evcmpx') CALL TEXT ('common/dtdp16/ p8z,evr8z(50),evi8z(50)') CALL TEXT ('common/dtdp19/ toler(neqnmx),adapt') CALL TEXT ('common/dtdp30/ econ8z,ncon8z') CALL TEXT ('common/dtdp42/ nxa8z,kd8z') CALL TEXT ('common/dtdp43/ work8z(nxp8z+3)') CALL TEXT ('common/dtdp45/ perdc(neqnmx)') CALL TEXT ('common/dtdp46/ eps8z,cgtl8z,npmx8z,itype,near8z') CALL TEXT ('common/dtdp62/ amin8z(2*neqnmx),amax8z(2*neqnmx)') CALL TEXT & ('common/dtdp75/ nx18z,xa,xb,uout(0:nx,2,neqn,0:nsave)') ELSE CALL TEXT & ('common/ tdp14/ sint8z(20),bint8z(20),slim8z(20),blim8z(20)') CALL TEXT ('common/ tdp15/ evlr8z,ev0r,evli8z,ev0i,evcmpx') CALL TEXT ('common/ tdp16/ p8z,evr8z(50),evi8z(50)') CALL TEXT ('common/ tdp19/ toler(neqnmx),adapt') CALL TEXT ('common/ tdp30/ econ8z,ncon8z') CALL TEXT ('common/ tdp42/ nxa8z,kd8z') CALL TEXT ('common/ tdp43/ work8z(nxp8z+3)') CALL TEXT ('common/ tdp45/ perdc(neqnmx)') CALL TEXT ('common/ tdp46/ eps8z,cgtl8z,npmx8z,itype,near8z') CALL TEXT ('common/ tdp62/ amin8z(2*neqnmx),amax8z(2*neqnmx)') CALL TEXT & ('common/ tdp75/ nx18z,xa,xb,uout(0:nx,2,neqn,0:nsave)') ENDIF CALL TEXT ('pi = 4.0*atan(1.d0)') CALL TEXT ('nxa8z = nxp8z') CALL TEXT ('nx18z = nx+1') CALL TEXT ('kd8z = kdeg8z') CALL MESS (0,8) CALL TEXT ('NPROB = 1') CALL INVAR ('NPROB',.FALSE.) CALL STATE (IST999) WRITE (LUN,5) IST999 5 FORMAT (6X,'do ',I5,' iprob=1,nprob') CALL MESS (0,135) CALL GUI() CALL GLOBP(LET1,48,LET2,52,FORB,26,PARNM,NPARN) CALL MESS (1,10) CALL IFYES (YES) LEVEL = 2 IF (YES) LEVEL = 3 C RECTANGULAR GRID CALL MESS (0,136) IF (DP) THEN CALL TEXT ('call dtdpwx(xgrid,nxgrid,0)') ELSE CALL TEXT ('call tdpwx(xgrid,nxgrid,0)') ENDIF C LUN = LPARAM CALL COM (1,'NXGRID = number of X-grid lines') CALL GUI() CALL INPARM ('NXGRID',NXGRID,2,INF) LUN = LFORT CALL COM (2,' XGRID DEFINED') CALL GUI() CALL INVAR ('XGRID(1)',.TRUE.) CALL INVEC ('XGRID',2,NXGRID - 1,.FALSE.) CALL GUI() CALL INVAR ('XGRID(NXGRID)',.TRUE.) IF (DP) THEN CALL TEXT ('call dtdpwx(xgrid,nxgrid,1)') ELSE CALL TEXT ('call tdpwx(xgrid,nxgrid,1)') ENDIF C LUN = LFORT C IDENTIFY TYPE OF PDE CALL MESS (1,11) CALL IREAD (' ',ITYPE,1,3) ELL = ITYPE .EQ. 1 PARA = ITYPE .EQ. 2 EIGEN = ITYPE .EQ. 3 IF (EIGEN) THEN C EIGENVALUE PROBLEM SOLVED CALL COM (2, ' *******EIGENVALUE PROBLEM') CALL MESS (0,12) CALL PAWS CALL TEXT ('ITYPE = 3') CALL COM (2,' ') CALL COM (2,' P8Z = 0.0') LINEAR = .TRUE. CALL TEXT ('linear = .true.') CALL TEXT ('t0 = 0.0') CALL TEXT ('dt = 1.0') CALL TEXT ('crankn = .false.') CALL TEXT ('noupdt = .true.') CALL MESS (0,13) CALL IFYES (EVCMPX) IF (.NOT.EVCMPX) THEN CALL TEXT ('EVCMPX = .FALSE.') CALL MESS (0,14) CALL TEXT ('EV0R = 0.0') CALL GUI() CALL INVAR ('EV0R', .FALSE.) ELSE CALL TEXT ('EVCMPX = .TRUE.') CALL MESS (0,15) CALL TEXT ('EV0R = 0.0') CALL TEXT ('EV0I = 0.0') CALL INVAR ('EV0R', .FALSE.) CALL INVAR ('EV0I', .FALSE.) ENDIF CALL MESS (0,16) CALL TEXT ('NSTEPS = 25') CALL INVAR ('NSTEPS',.FALSE.) ELSE IF (PARA) THEN C TIME DEPENDENT PROBLEM SOLVED CALL COM (2,' *******TIME-DEPENDENT PROBLEM') CALL TEXT ('itype = 2') CALL MESS (0,17) CALL TEXT ('T0 = 0.0') CALL GUI() CALL INVAR ('T0',.FALSE.) CALL GUI() CALL INVAR ('TF',.TRUE.) CALL MESS (0,18) CALL IFYES (LINEAR) IF (LINEAR) THEN CALL TEXT ('LINEAR = .TRUE.') ELSE CALL TEXT ('LINEAR = .FALSE.') ENDIF CALL MESS (0,19) CALL IFYES (YES) CALL GUI() IF (YES) THEN CALL TEXT ('ADAPT = .TRUE.') CALL TEXT ('TOLER(1) = 0.01') CALL INVAR ('TOLER(1)', .FALSE.) IF (LINEAR) CALL MESS (2,20) CALL TEXT ('NOUPDT = .FALSE.') CALL MESS (0,21) ELSE CALL TEXT ('ADAPT = .FALSE.') CALL TEXT ('TOLER(1) = 0.01') IF (LINEAR) THEN CALL MESS (0,20) CALL IFYES (YES) CALL GUI() IF (YES) THEN CALL TEXT ('NOUPDT = .TRUE.') ELSE CALL TEXT ('NOUPDT = .FALSE.') ENDIF ELSE CALL TEXT ('NOUPDT = .FALSE.') ENDIF CALL MESS (0,22) ENDIF CALL GUI() CALL INVAR ('NSTEPS',.TRUE.) CALL TEXT ('dt = (tf-t0)/max(nsteps,1)') CALL MESS (0,65) CALL IFYES (YES) IF (YES) THEN CALL TEXT ('CRANKN = .TRUE.') ELSE CALL TEXT ('CRANKN = .FALSE.') ENDIF ELSE C STEADY STATE PROBLEM SOLVED CALL COM (2,' *******STEADY-STATE PROBLEM') CALL TEXT ('itype = 1') CALL TEXT ('t0 = 0.0') CALL TEXT ('dt = 1.0') CALL TEXT ('crankn = .false.') CALL TEXT ('noupdt = .false.') CALL MESS (0,18) CALL IFYES (LINEAR) IF (LINEAR) THEN CALL TEXT ('LINEAR = .TRUE.') CALL COM (2, ' Number of Newton iterations') CALL TEXT ('NSTEPS = 1') ELSE CALL TEXT ('LINEAR = .FALSE.') CALL MESS (0,24) CALL TEXT ('NSTEPS = 15') CALL INVAR ('NSTEPS',.FALSE.) ENDIF ENDIF LUN = LPARAM CALL MESS (0,25) CALL INPARM ('NEQN',NEQN,1,NEQNMX) LUN = LFORT CALL MESS (1,137) CALL VARNAM(LET1,36,LET2,40,FORB,4,NEQN) IND = MIN(NEQN-1,3) C FINITE DIFFERENCE JACOBIAN? IF (LINEAR) THEN FDIFF = .FALSE. ELSE CALL MESS (0,27) CALL IFYES (FDIFF) ENDIF IF (FDIFF) THEN CALL TEXT ('FDIFF = .TRUE.') ELSE CALL TEXT ('FDIFF = .FALSE.') ENDIF C PDES DEFINED LUN = LFUNS CALL TEXT (' ') CALL TEXT (' ') CALL TEXT & ('subroutine pdes8z(yd8z,i8z,j8z,kint8z,x,t,uu8z)') CALL PREC WRITE (LUN,90) NEQNMX 90 FORMAT (6X,'parameter (neqnmx=',I4,')') IF (EIGEN) WRITE (LUN,95) NEQN 95 FORMAT (6X,'parameter (NEQN=',I4,')') CALL COM (2, ' un8z(1,I),un8z(2,I),un8z(3,I) hold'// & ' the (rarely used) values') CALL COM (2, ' of UI,UIx,UIxx from the previous'// & ' iteration or time step') IF (DP) THEN CALL TEXT ('common /dtdp4x/un8z(3,neqnmx)') CALL TEXT ('common /dtdp11/normx') CALL TEXT ('double precision normx,uu8z(3,neqnmx)') ELSE CALL TEXT ('common / tdp4x/un8z(3,neqnmx)') CALL TEXT ('common / tdp11/normx') CALL TEXT ('real normx,uu8z(3,neqnmx)') ENDIF IF (EIGEN.AND.(NEQN.GT.1)) CALL TEXT('dimension rho(neqn,neqn)') WRITE (LUN,395) (PARNM(I),I=1,NPARN) DO 130 IEQ = 1,NEQN WRITE (LUN,100) UNK(IEQ)(1:NUNK(IEQ)),IEQ 100 FORMAT(6X,A,' = uu8z(1,',I2,')') WRITE (LUN,110) UNK(IEQ)(1:NUNK(IEQ)),IEQ 110 FORMAT(6X,A,'x = uu8z(2,',I2,')') WRITE (LUN,120) UNK(IEQ)(1:NUNK(IEQ)),IEQ 120 FORMAT(6X,A,'xx= uu8z(3,',I2,')') 130 CONTINUE CALL TEXT (' if (i8z.eq.0) then') CALL TEXT ('yd8z = 0.0') LUN = LFORT CALL MESS (0,28) CALL GUI() CALL IREAD ('NINT', NINT, 0, 20) LUN = LFUNS IF (NINT.GT.0) THEN CALL MESS (0,138 + IND) CALL IADD (3, 'the integrals') DO 140 I=1,NINT CALL GUI() CALL VECFUN('INTEGRAL',I,NINT,I,'yd8z',0,'kint8z') 140 CONTINUE ELSE CALL MESS (2,138 + IND) WRITE (LUN,150) 150 FORMAT ('C',50X,'INTEGRAL1 DEFINED',/, & 'C if (kint8z.eq.1) yd8z =',/, & 'C & [DEFAULT SELECTED, DEFINITION COMMENTED OUT]') ENDIF LUN = LFORT CALL MESS (0,74) CALL IREAD ('NBINT', NBINT, 0, 20) LUN = LFUNS IF (NBINT.GT.0) THEN CALL MESS (0,142 + IND) CALL IADD (3, 'the boundary integrals') DO 155 I=1,NBINT CALL VECFUN('BND. INTEGRAL',I,NBINT,(-I),'yd8z',0,'kint8z') 155 CONTINUE ELSE CALL MESS (2,142 + IND) WRITE (LUN,156) 156 FORMAT ('C',50X,'BND. INTEGRAL1 DEFINED',/, & 'C if (kint8z.eq.-1) yd8z =',/, & 'C & [DEFAULT SELECTED, DEFINITION COMMENTED OUT]') ENDIF CALL TEXT (' else') IF (EIGEN) THEN CALL MESS (0,146 + IND) CALL IADD (2,'these coefficients') ELSE IF (ELL) THEN CALL MESS (0,150 + IND) CALL IADD (2,'these coefficients') ELSE IF (PARA) THEN CALL MESS (0,154 + IND) CALL IADD (2,'these coefficients') ENDIF CALL TEXT (' if (j8z.eq.0) then') CALL TEXT ('yd8z = 0.0') DO 160 I = 1,NEQN IF (PARA) THEN CALL GUI() DO 159 J = 1,NEQN LL = 100*I+J IF (NEQN.EQ.1) THEN CALL VECFUN ('C',1,1,(-LL),'yd8z',2,'i8z') ELSE IF (NEQN.LE.9) THEN WRITE (CNUM6,157) I,J 157 FORMAT ('C(',I1,',',I1,')') CALL VECFUN (CNUM6,1,1,(-LL),'yd8z',2,'i8z') ELSE WRITE (CNUM8,158) I,J 158 FORMAT ('C(',I2,',',I2,')') CALL VECFUN (CNUM8,1,1,(-LL),'yd8z',2,'i8z') ENDIF 159 CONTINUE ENDIF CALL GUI() CALL VECFUN ('F',I,NEQN,I,'yd8z',0,'i8z') IF (EIGEN) THEN CALL GUI() IF (NEQN .EQ. 1) THEN CALL COM (2, & ' RHO DEFINED') CALL INVAR ('RHO', .TRUE.) ELSE CALL COM (2, & ' RHO DEFINED') CALL INMAT ('RHO', I, I, 1, NEQN, .TRUE.) ENDIF ENDIF 160 CONTINUE IF (EIGEN) THEN IF (DP) THEN CALL TEXT ('call dtdpsx (yd8z,i8z,uu8z,un8z,rho,3,neqn)') ELSE CALL TEXT ('call tdpsx (yd8z,i8z,uu8z,un8z,rho,3,neqn)') ENDIF ENDIF CALL TEXT (' else') IF (.NOT.LINEAR .AND. .NOT.FDIFF) THEN DO 165 I = 1,NEQN DO 164 J = 1,NEQN JJ = 3*(J-1) CALL MATFUN('F', I, NEQN, UNK(J)(1:NUNK(J)), & I, JJ+1, 'yd8z', 0) CALL MATFUN('F', I, NEQN, UNK(J)(1:NUNK(J))//'x', & I, JJ+2, 'yd8z', 0) CALL MATFUN('F', I, NEQN, UNK(J)(1:NUNK(J))//'xx', & I, JJ+3, 'yd8z', 0) 164 CONTINUE 165 CONTINUE ENDIF CALL TEXT (' endif') CALL TEXT (' endif') CALL TEXT ('return') CALL TEXT ('end') C INITIAL VALUES SPECIFIED CALL TEXT (' ') CALL TEXT (' ') CALL TEXT ('function u8z(i8z,x,t0)') CALL PREC WRITE (LUN,395) (PARNM(I),I=1,NPARN) IF (EIGEN) THEN IF (DP) THEN CALL TEXT ('u8z = dtdpxx()') ELSE CALL TEXT ('u8z = tdpxx()') ENDIF ELSE CALL TEXT ('u8z = 0.0') ENDIF IF ( .NOT.ELL .OR. .NOT.LINEAR) THEN IF (EIGEN) CALL MESS (0,94) IF (ELL) CALL MESS (0,95) IF (PARA) CALL MESS (0,96) CALL IADD (3,'the initial values') DO 170 I = 1,NEQN IF (EIGEN) THEN CALL VECFUN (UNK(I)(1:NUNK(I))//'0',0,1,I, & 'u8z',1,'i8z') ELSE CALL GUI() CALL VECFUN (UNK(I)(1:NUNK(I))//'0',0,1,I, & 'u8z',2,'i8z') ENDIF 170 CONTINUE LUN = LFORT IF (PARA) THEN CALL MESS (0,158) CALL IFYES(YES) IF (YES) THEN CALL TEXT ('LSQFIT = .TRUE.') ELSE CALL TEXT ('LSQFIT = .FALSE.') ENDIF ELSE CALL TEXT ('lsqfit = .false.') ENDIF CALL MESS (0,48) CALL IFYES(RESTRT) IF (RESTRT) THEN CALL TEXT ('RESTRT = .TRUE.') CALL MESS (0,97) CALL IFYES(YES) IF (YES) THEN CALL TEXT ('GRIDID = .TRUE.') ELSE CALL TEXT ('GRIDID = .FALSE.') ENDIF ELSE CALL TEXT ('RESTRT = .FALSE.') CALL COM (2,'GRIDID = .FALSE. IF FINITE ELEMENT'// & ' GRID CHANGES BETWEEN DUMP, RESTART') CALL TEXT ('GRIDID = .TRUE.') ENDIF ELSE LUN = LFORT CALL TEXT ('lsqfit = .false.') CALL TEXT ('RESTRT = .FALSE.') CALL TEXT ('GRIDID = .TRUE.') ENDIF LUN = LFUNS CALL TEXT ('return') CALL TEXT ('end') C BOUNDARY CONDITIONS DEFINED LUN = LFORT CALL MESS (0,159) CALL GUI() CALL IREAD ('IPERDC',IPERDC,0,1) LUN = LFUNS CALL TEXT (' ') CALL TEXT (' ') CALL TEXT & ('subroutine gb8z(gd8z,ifac8z,i8z,j8z,x,t,uu8z)') CALL PREC WRITE (LUN,90) NEQNMX CALL TEXT ('dimension uu8z(3,neqnmx)') CALL COM (2, ' un8z(1,I),un8z(2,I) hold'// & ' the (rarely used) values') CALL COM (2, ' of UI,UIx from the previous'// & ' iteration or time step') IF (DP) THEN CALL TEXT ('common /dtdp4x/ un8z(3,neqnmx)') CALL TEXT ('double precision none') WRITE (LUN,395) (PARNM(I),I=1,NPARN) CALL TEXT ('none = dtdplx(2)') ELSE CALL TEXT ('common / tdp4x/ un8z(3,neqnmx)') CALL TEXT ('real none') WRITE (LUN,395) (PARNM(I),I=1,NPARN) CALL TEXT ('none = tdplx(2)') ENDIF DO 180 IEQ = 1,NEQN WRITE (LUN,100) UNK(IEQ)(1:NUNK(IEQ)),IEQ WRITE (LUN,110) UNK(IEQ)(1:NUNK(IEQ)),IEQ 180 CONTINUE CALL TEXT ('if (j8z.eq.0) gd8z = 0.0') CALL MESS (0,160 + IND) DO 240 IFACE = 1,2 WRITE (LUN,190) IFACE 190 FORMAT (12X,'if (ifac8z.eq.',I2,') then') CALL MESS (0,164 + IFACE - 1) IF (IPERDC.EQ.0) THEN CALL IADD (3, & 'the boundary conditions (at this endpoint only)') CALL TEXT (' if (j8z.eq.0) then') IDEF = 0 ELSE WRITE (INTOUT,200) IPERDC 200 FORMAT (/,' IPERDC = ',I1, & ', so periodic boundary conditions set automatically') CALL PAWS CALL TEXT (' if (j8z.eq.0) then') CALL COM (2, & ' PERIODIC BOUNDARY CONDITIONS SET (SEE IPERDC)') IDEF = 3 ENDIF DO 210 I = 1,NEQN IF (IDEF.EQ.0) CALL GUI() CALL VECFUN ('G',I,NEQN,I,'gd8z',IDEF,'i8z') 210 CONTINUE CALL TEXT (' else') IF (.NOT.LINEAR .AND. .NOT.FDIFF) THEN DO 230 I = 1,NEQN DO 220 J = 1,NEQN JJ = 3*(J-1) CALL MATFUN('G', I, NEQN, UNK(J)(1:NUNK(J)), & I, JJ+1, 'gd8z', IDEF) CALL MATFUN('G', I, NEQN, UNK(J)(1:NUNK(J))//'x', & I, JJ+2, 'gd8z', IDEF) 220 CONTINUE 230 CONTINUE ENDIF CALL TEXT (' endif') CALL TEXT (' endif') 240 CONTINUE C CALL TEXT ('return') CALL TEXT ('end') C OUTPUT MODIFICATION FUNCTIONS DEFINED LUN = LFUNS CALL TEXT (' ') CALL TEXT (' ') CALL TEXT ('subroutine pmod8z(x,t,uu8z,uprint,uxprint)') CALL PREC CALL TEXT ('dimension uu8z(3,*),uprint(*),uxprint(*)') IF (DP) THEN CALL TEXT & ('common/dtdp14/sint(20),bint(20),slim8z(20),blim8z(20)') ELSE CALL TEXT & ('common/ tdp14/sint(20),bint(20),slim8z(20),blim8z(20)') ENDIF WRITE (LUN,395) (PARNM(I),I=1,NPARN) DO 250 IEQ = 1,NEQN WRITE (LUN,100) UNK(IEQ)(1:NUNK(IEQ)),IEQ WRITE (LUN,110) UNK(IEQ)(1:NUNK(IEQ)),IEQ WRITE (LUN,120) UNK(IEQ)(1:NUNK(IEQ)),IEQ 250 CONTINUE CALL MESS (0,166 + IND) CALL IADD (3,'these variables') CALL COM (2, ' DEFINE UPRINT(*),UXPRINT(*) HERE:') DO 255 I=1,NEQN WRITE (INTOUT,251) UNK(I)(1:NUNK(I)) 251 FORMAT (' Replace ',A,' for postprocessing?') CALL INVEC ('UPRINT',I,I,.FALSE.) WRITE (INTOUT,252) UNK(I)(1:NUNK(I)) 252 FORMAT (' Replace ',A,'x for postprocessing?') CALL INVEC ('UXPRINT',I,I,.FALSE.) 255 CONTINUE CALL TEXT ('return') CALL TEXT ('end') C CALCULATE STORAGE REQUIREMENTS LUN = LPARAM CALL COM (2,' DIMENSIONS OF WORK ARRAYS') IRWK = 1 IIWK = 1 CALL COM (2, ' SET TO 1 FOR AUTOMATIC ALLOCATION') WRITE (LUN,260) IRWK,IIWK 260 FORMAT (6X,'PARAMETER (IRWK8Z=',I12,')',/, 6X,'PARAMETER (IIWK8Z=' &,I12,')') CALL TEXT ('PARAMETER (NXP8Z=1001,KDEG8Z=1)') C OUTPUT PARAMETERS CALL MESS (0,115) CALL IREAD (' ',NX,-INF,INF) IF (NX.LE.0) THEN WRITE (LUN,265) -NX 265 FORMAT (6X,'PARAMETER (NX = ',I10,')') LUN = LFORT CALL TEXT ('npts8z = nx+1') CALL MESS (0,116) CALL IADD (0, ' ') ELSE WRITE (LUN,265) NX LUN = LFORT CALL MESS (0,117) CALL COM (2,' defaults for xa,xb') CALL TEXT ('xa = xgrid(1)') CALL TEXT ('xb = xgrid(nxgrid)') CALL COM (2,' DEFINE XA,XB IMMEDIATELY BELOW:') CALL INVAR ('XA',.FALSE.) CALL INVAR ('XB',.FALSE.) IF (DP) THEN CALL TEXT ('call dtdpx1(nx,xa,xb,hx8z,xout8z,npts8z)') ELSE CALL TEXT ('call tdpx1(nx,xa,xb,hx8z,xout8z,npts8z)') ENDIF ENDIF IF (PARA) THEN LUN = LPARAM CALL MESS (0,53) CALL INPARM ('NSAVE', NSAVE, 1, INF) LUN = LFORT ELSE LUN = LPARAM NSAVE = 1 CALL TEXT ('PARAMETER (NSAVE = 1)') LUN = LFORT CALL COM (2, ' SOLUTION SAVED EVERY NOUT ITERATIONS') CALL TEXT ('NOUT = NSTEPS') ENDIF IF (DP) THEN CALL TEXT ('call dtdp1q(nxgrid,neqn,ii8z,ir8z)') ELSE CALL TEXT ('call tdp1q(nxgrid,neqn,ii8z,ir8z)') ENDIF CALL TEXT ('if (iiwk8z.gt.1) ii8z = iiwk8z') CALL TEXT ('if (irwk8z.gt.1) ir8z = irwk8z') CALL COM (2, ' *******allocate workspace') CALL TEXT ('allocate (iwrk8z(ii8z),rwrk8z(ir8z))') CALL COM (2,' *******DRAW GRID POINTS?') CALL TEXT ('PLOT = .TRUE.') CALL COM (2,' *******call pde solver') IF (DP) THEN CALL TEXT ('call dtdp1x(xgrid, nxgrid, neqn, nint, nbint,'// & ' xout8z, uout, tout8z, iperdc, plot, lsqfit, fdiff,'// & ' npts8z, t0, dt, nsteps, nout, nsave, crankn, noupdt,'// & ' itype, linear, rwrk8z, ir8z, iwrk8z, ii8z, restrt, gridid)') ELSE CALL TEXT ('call tdp1x(xgrid, nxgrid, neqn, nint, nbint,'// & ' xout8z, uout, tout8z, iperdc, plot, lsqfit, fdiff,'// & ' npts8z, t0, dt, nsteps, nout, nsave, crankn, noupdt,'// & ' itype, linear, rwrk8z, ir8z, iwrk8z, ii8z, restrt, gridid)') ENDIF CALL TEXT ('deallocate (iwrk8z,rwrk8z)') IF (EIGEN) THEN WRITE (LUN,270) IST999 270 FORMAT (6X,'if (itype.eq.4) go to ',I5) CALL COM (2, & ' *******UNCOMMENT TO POSTPROCESS ONLY IF CONVERGED') WRITE (LUN,275) IST999 275 FORMAT ('C',6X,'IF (.NOT.ECON8Z) GO TO ',I5) ENDIF IF (ELL.AND.(.NOT.LINEAR)) THEN CALL COM (2, & ' *******UNCOMMENT TO POSTPROCESS ONLY IF CONVERGED') WRITE (LUN,276) IST999 276 FORMAT ('C',6X,'IF (.NOT.NCON8Z) GO TO ',I5) ENDIF IF (DP) THEN CALL COM (2, & ' *******read from restart file to array ures8z') CALL COM (2,' call dtdpr1(1,xres8z,nxp8z,ures8z,neqn)') CALL COM (2, & ' *******write array ures8z back to restart file') CALL COM (2,' call dtdpr1(2,xres8z,nxp8z,ures8z,neqn)') ELSE CALL COM (2, & ' *******read from restart file to array ures8z') CALL COM (2,' call tdpr1(1,xres8z,nxp8z,ures8z,neqn)') CALL COM (2, & ' *******write array ures8z back to restart file') CALL COM (2,' call tdpr1(2,xres8z,nxp8z,ures8z,neqn)') ENDIF CALL COM (2,' *******call user-written postprocessor') CALL TEXT ('call postpr(tout8z,nsave,xout8z,nx,uout,neqn)') 280 CONTINUE CALL MESS (1,118) IPLIM = 3 IF (.NOT.PARA) IPLIM = 2 CALL IREAD (' ',IPLOT,0,IPLIM) IF (IPLOT .EQ. 0) THEN GO TO 300 ELSE IF (IPLOT .EQ. 1) THEN C TABLE OF VALUES AT OUTPUT POINTS CALL COM (2,' *******TABULAR OUTPUT') CALL MESS (0,170 + IND) CALL IREAD ('IVAR',IVAR,1,2*NEQN) CALL TEXT ('ivara8z = mod(ivar-1,2)+1') CALL TEXT ('ivarb8z = (ivar-1)/2+1') IF (.NOT.PARA) THEN CALL TEXT ('ISET1 = 1') CALL TEXT ('ISET2 = NSAVE') CALL TEXT ('ISINC = 1') ELSE CALL MESS (0,123) CALL TEXT ('ISET1 = 0') CALL TEXT ('ISET2 = NSAVE') CALL TEXT ('ISINC = 1') CALL INVAR ('ISET1',.FALSE.) CALL INVAR ('ISET2',.FALSE.) CALL INVAR ('ISINC',.FALSE.) ENDIF CALL MESS (0,59) CALL TEXT ('TITLE = '' '' ') CALL INSTR ('TITLE',.FALSE.) CALL STATE (ISTAT) IF (DP) THEN CALL TEXT('call dtdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,450) ISTAT CALL TEXT ('call dtdp1d(xout8z,'// & 'uout(0,ivara8z,ivarb8z,is8z),npts8z,title,tout8z(is8z))') ELSE CALL TEXT('call tdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,450) ISTAT CALL TEXT ('call tdp1d(xout8z,'// & 'uout(0,ivara8z,ivarb8z,is8z),npts8z,title,tout8z(is8z))') ENDIF WRITE (LUN,470) ISTAT ELSE IF (IPLOT .EQ. 2) THEN C LINE PLOTS CALL COM (2, ' *******LINE PLOTS') CALL MESS (0,170 + IND) CALL IREAD ('IVAR', IVAR, 1, 2*NEQN) CALL MESS (1,124) ICSLIM = 2 IF (.NOT.PARA) ICSLIM = 1 CALL IREAD (' ', ICS, 1, ICSLIM) IF (ICS.EQ.1) THEN CALL COM (2, ' X IS VARIABLE') CALL TEXT ('ics8z = 1') ELSE IF (ICS.EQ.2) THEN CALL COM (2, ' T IS VARIABLE') CALL TEXT ('ics8z = 2') CALL MESS (0,125) CALL IREAD ('NXVALS', NXVALS, 1, 100) CALL INVEC ('XCROSS', 1, NXVALS, .TRUE.) ENDIF IF (ICS.EQ.1) THEN IF (.NOT.PARA) THEN CALL TEXT ('ISET1 = 1') CALL TEXT ('ISET2 = NSAVE') CALL TEXT ('ISINC = 1') ELSE CALL MESS (0,123) CALL TEXT ('ISET1 = 0') CALL TEXT ('ISET2 = NSAVE') CALL TEXT ('ISINC = 1') CALL INVAR ('ISET1',.FALSE.) CALL INVAR ('ISET2',.FALSE.) CALL INVAR ('ISINC',.FALSE.) ENDIF ENDIF CALL COM (2,' ') CALL TEXT ('alow = amin8z(ivar)') CALL TEXT ('ahigh = amax8z(ivar)') CALL MESS (0,126) CALL TEXT ('UMIN = 0.0') CALL TEXT ('UMAX = 0.0') CALL INVAR ('UMIN', .FALSE.) CALL INVAR ('UMAX', .FALSE.) CALL MESS (0,59) CALL TEXT ('TITLE = '' '' ') CALL INSTR ('TITLE',.FALSE.) CALL STATE (ISTAT) IF (DP) THEN IF (ICS.EQ.1) THEN CALL TEXT('call dtdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,450) ISTAT ELSE IF (ICS.EQ.2) THEN CALL TEXT ('is8z = 0') WRITE (LUN,290) ISTAT CALL TEXT ('call dtdpzy(xcross(ixv8z),xout8z,nx,ix8z)') ENDIF CALL TEXT ('call dtdpzp(ics8z,ivar,tout8z,nsave,'// & 'xout8z,nx,uout,neqn,title,umin,umax,ix8z,is8z)') ELSE IF (ICS.EQ.1) THEN CALL TEXT('call tdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,450) ISTAT ELSE IF (ICS.EQ.2) THEN CALL TEXT ('is8z = 0') WRITE (LUN,290) ISTAT CALL TEXT ('call tdpzy(xcross(ixv8z),xout8z,nx,ix8z)') ENDIF CALL TEXT ('call tdpzp(ics8z,ivar,tout8z,nsave,'// & 'xout8z,nx,uout,neqn,title,umin,umax,ix8z,is8z)') ENDIF WRITE (LUN,470) ISTAT ELSE IF (IPLOT.EQ.3) THEN C SURFACE PLOT CALL COM (2, ' *******SURFACE PLOT') CALL MESS (0,170 + IND) CALL IREAD ('IVAR', IVAR, 1, 2*NEQN) CALL MESS (0,127) CALL TEXT ('VLON = 45.0') CALL TEXT ('VLAT = 45.0') CALL INVAR ('VLAT', .FALSE.) CALL INVAR ('VLON', .FALSE.) CALL MESS (0,60) CALL TEXT ('UMIN = 0.0') CALL TEXT ('UMAX = 0.0') CALL INVAR ('UMIN', .FALSE.) CALL INVAR ('UMAX', .FALSE.) CALL MESS (0,59) CALL TEXT ('TITLE = '' '' ') CALL INSTR ('TITLE',.FALSE.) IF (DP) THEN CALL TEXT ('call dtdpzd(xout8z,tout8z,uout,nx,'// & 'nsave,title,neqn,ivar,vlon,vlat,umin,umax)') ELSE CALL TEXT ('call tdpzd(xout8z,tout8z,uout,nx,'// & 'nsave,title,neqn,ivar,vlon,vlat,umin,umax)') ENDIF ENDIF GO TO 280 290 FORMAT (6X,'do ',I5,' ixv8z=1,nxvals') 300 CONTINUE C ADD DUMMY PDE2D FUNCTIONS LUN = LFUNS CALL COM (2,' dummy routines') CALL TEXT ('subroutine xy8z(i8z,iarc8z,s,x,y,s0,sf)') CALL PREC CALL TEXT ('return') CALL TEXT ('end') CALL TEXT ('subroutine dis8z(x,y,ktri,triden,shape)') CALL PREC CALL TEXT ('return') CALL TEXT ('end') CALL TEXT ('function fb8z(i8z,iarc8z,ktri,s,x,y,t)') CALL PREC CALL TEXT ('fb8z = 0') CALL TEXT ('return') CALL TEXT ('end') CALL TEXT ('function axis8z(i8z,x,y,z,ical8z)') CALL PREC CALL TEXT ('axis8z = 0') CALL TEXT ('return') CALL TEXT ('end') CALL TEXT ('subroutine tran8z(itrans,x,y,z)') CALL PREC CALL TEXT ('return') CALL TEXT ('end') C WRITE POSTPR CALL TEXT (' ') CALL TEXT (' ') CALL TEXT ( &'subroutine postpr(tout,nsave,xout,nx,uout,neqn)') CALL PREC CALL TEXT ('dimension xout(0:nx),tout(0:nsave)') CALL TEXT ('dimension uout(0:nx,2,neqn,0:nsave)') WRITE (LUN,395) (PARNM(I),I=1,NPARN) IF (DP) THEN CALL TEXT ('common /dtdp27/ itask,npes,icomm') CALL TEXT ('common /dtdp46/ eps8z,cgtl8z,npmx8z,itype,near8z') ELSE CALL TEXT ('common / tdp27/ itask,npes,icomm') CALL TEXT ('common / tdp46/ eps8z,cgtl8z,npmx8z,itype,near8z') ENDIF CALL TEXT ('data lun,lud/0,47/') CALL TEXT ('if (itask.gt.0) return') CALL COM (2,'UOUT(I,IDER,IEQ,L) = U_IEQ, if IDER=1') CALL COM (2,' Ux_IEQ, if IDER=2') CALL COM (2,' (possibly as modified by UPRINT,..)') CALL COM (2,' at the point XOUT(I)') CALL COM (2,' at time/iteration TOUT(L).') CALL COM (2,' ******* ADD POSTPROCESSING CODE HERE:') CALL COM (2,' IN THE EXAMPLE BELOW, MATLAB PLOTFILES pde2d.m,') CALL COM (2,' pde2d.rdm CREATED (REMOVE C! COMMENTS TO ACTIVATE)') CALL COM (3,' if (lun.eq.0) then') CALL COM (3,' lun = 46') CALL COM (3,' open (lun,file=''pde2d.m'')') CALL COM (3,' open (lud,file=''pde2d.rdm'')') CALL COM (3, & ' write (lun,*) ''fid = fopen(''''pde2d.rdm'''');''') CALL COM (3,' endif') CALL COM (3,' do 78753 l=0,nsave') IF (DP) THEN CALL COM (3,' if (tout(l).ne.dtdplx(2)) nsave0 = l') ELSE CALL COM (3,' if (tout(l).ne. tdplx(2)) nsave0 = l') ENDIF CALL COM (4,'78753 continue') CALL COM (3,' write (lud,78754) nsave0') CALL COM (3,' write (lud,78754) neqn') CALL COM (3,' write (lud,78754) nx') CALL COM (4,'78754 format (i8)') CALL COM (3,' do 78755 i=0,nx') CALL COM (3,' write (lud,78760) xout(i)') CALL COM (4,'78755 continue') CALL COM (3,' do 78759 l=0,nsave0') CALL COM (3,' write (lud,78760) tout(l)') CALL COM (3,' do 78758 ieq=1,neqn') CALL COM (3,' do 78757 ider=1,2') CALL COM (3,' do 78756 i=0,nx') CALL COM (3,' write (lud,78760) uout(i,ider,ieq,l)') CALL COM (4,'78756 continue') CALL COM (4,'78757 continue') CALL COM (4,'78758 continue') CALL COM (4,'78759 continue') CALL COM (4,'78760 format (e16.8)') CALL COM (2,' ******* WRITE pde2d.m ') CALL COM (3,' call mtdp1dc(itype,lun)') CALL TEXT ('return') CALL TEXT ('end') C ENTER USER-SUPPLIED FUNCTIONS CALL MESS (1,61) CALL IFYES (YES) IF (YES) CALL IADD (0,' ') C CALL TDP1E/DTDP1E TO INTERPOLATE TABULAR OUTPUT CALL MESS (1,128) CALL IFYES (YES) IF (YES) THEN C 310 CONTINUE CALL MESS (1,129) 320 CONTINUE WRITE (INTOUT,330) 330 FORMAT (' Function name =') CALL READLN (INPT,6,NOMORE) IF (NOMORE) THEN WRITE (INTOUT,350) GO TO 320 ENDIF DO 340 I = 1,40 IF (INPT(1) .EQ. LET2(I)) GO TO 360 340 CONTINUE WRITE (INTOUT,350) 350 FORMAT ('|---- Illegal function name, re-enter in columns 1-6') GO TO 320 360 CONTINUE WRITE (LUN,370) INPT 370 FORMAT (//,6X,'function ',6A1,'(x)') CALL PREC CALL MESS (0,130) CALL INPARM ('NWORK',NWORK,5,INF) CALL TEXT ('dimension work(nwork)') CALL TEXT ('character*40 fname') IF (DP) THEN CALL TEXT ('data work(1) /0.0d0/') ELSE CALL TEXT ('data work(1) /0.0/') ENDIF CALL MESS (0,131) CALL INSTR ('FNAME',.TRUE.) CALL MESS (0,132) CALL TEXT ('ISET = 1') CALL INVAR ('ISET',.FALSE.) CALL MESS (0,133) CALL IREAD ('KDEG',KDEG,1,3) IF (DP) THEN WRITE (LUN,380) INPT 380 FORMAT (6X,6A1,' = dtdp1e(fname,iset,work,nwork,kdeg,x)') ELSE WRITE (LUN,390) INPT 390 FORMAT (6X,6A1,' = tdp1e(fname,iset,work,nwork,kdeg,x)') ENDIF CALL TEXT ('return') CALL TEXT ('end') CALL MESS (1,134) CALL IFYES (YES) IF (YES) GO TO 310 C ENDIF CALL MESS (1,411) LUN = LFORT WRITE (LUN,470) IST999 CALL TEXT ('call endgks') CALL TEXT ('stop') CALL TEXT ('end') LUN = LPARAM WRITE (LUN,395) (PARNM(I),I=1,NPARN) 395 FORMAT (6X,'common/parm8z/ pi',6A7,/,(5X,'&',9A7)) C CONCATENATE PARAMETERS FILE, MAIN PROGRAM, AND SUBPROGRAMS REWIND LFORT 400 CONTINUE READ (LFORT,410,END=420) LINE 410 FORMAT (A79) WRITE (LPARAM,410) LINE GO TO 400 420 CONTINUE REWIND LFUNS 430 CONTINUE READ (LFUNS,410,END=440) LINE WRITE (LPARAM,410) LINE GO TO 430 440 CONTINUE 450 FORMAT (6X,'do ',I5,' is8z=iset1,iset2,isinc') 470 FORMAT (I5,' continue') STOP END SUBROUTINE PDE2DG PARAMETER (NEQNMX=99) PARAMETER (NDELMX=20) LOGICAL YES,EIGEN,PARA,ELL,LINEAR,SYMM,NOMORE,EVCMPX, & FDIFF,DP,RESTRT,UNCOM COMMON /EXMP/ LEVEL,IEXMP,DP COMMON /LUNITS/ INTIN,INTOUT,LMESS,LUN,LPARAM,LFORT,LFUNS,INFIL & ,IECHO COMMON /UNKNWN/ NUNK(NEQNMX),UNK(NEQNMX) COMMON /PARMS/ LSCREN,ISMX2D,ISMX3D,UNCOM C CHARACTER VARIABLES CHARACTER*79 LINE CHARACTER*8 CNUM8 CHARACTER*6 CNUM6 CHARACTER*7 PARNM(176) CHARACTER*3 UNK,FORB(80) CHARACTER*1 INPT(6),LET1(40),LET2(52) DATA LET1 / & 'P','Q','p','q','C','D','E','F','G','H','O','R','U','V', & 'W','Z','c','d','e','f','g','h','o','r','u','v','w','z', & 'I','J','K','L','M','N','i','j','k','l','m','n'/ DATA LET2 / 'A','B','C','D','E','F','G','H','O','P', & 'Q','R','S','T','U','V','W','X','Y','Z', & 'a','b','c','d','e','f','g','h','o','p', & 'q','r','s','t','u','v','w','x','y','z', & 'I','J','K','L','M','N','i','j','k','l','m','n'/ DATA FORB/ & 'A1 ','A2 ','A3 ','A4 ','A5 ','A6 ','A7 ','A8 ','A9 ','PI ', & 'a1 ','a2 ','a3 ','a4 ','a5 ','a6 ','a7 ','a8 ','a9 ','Pi ', & 'B1 ','B2 ','B3 ','B4 ','B5 ','B6 ','B7 ','B8 ','B9 ','pI ', & 'b1 ','b2 ','b3 ','b4 ','b5 ','b6 ','b7 ','b8 ','b9 ','pi ', & 'NX ','NY ','DT ','TF ','XA ','XB ','YA ','YB ','SF ','T0 ', & 'Nx ','Ny ','Dt ','Tf ','Xa ','Xb ','Ya ','Yb ','Sf ','t0 ', & 'nX ','nY ','dT ','tF ','xA ','xB ','yA ','yB ','sF ','S0 ', & 'nx ','ny ','dt ','tf ','xa ','xb ','ya ','yb ','sf ','s0 '/ INF = 10000 CALL COM (2,'*** 2D PROBLEM SOLVED (GALERKIN METHOD) ***') CALL MESS (0,7) CALL IFYES (DP) CALL PREC WRITE (LUN,120) NEQNMX WRITE (LUN,125) NDELMX LUN = LFORT CALL TEXT ('dimension vxy(2,nv0+1),iabc(3,nt0+1),iarc(nt0+1),'// & 'xgrid(nxgrid+1),ygrid(nygrid+1),ixarc(2),iyarc(2),'// & 'pgrid(npgrid+1),qgrid(nqgrid+1),iparc(2),iqarc(2),'// & 'xbd8z(nbpt8z,nt0+4),ybd8z(nbpt8z,nt0+4),xout8z(0:nx,0:ny),'// & 'yout8z(0:nx,0:ny),inrg8z(0:nx,0:ny),xcross(100),ycross(100),'// & 'tout8z(0:nsave),xd0(ndelmx),yd0(ndelmx)') CALL COM (2, &' dimension xres8z(nxp8z),yres8z(nyp8z),ures8z(neqn,nxp8z,nyp8z)') CALL TEXT ('allocatable iwrk8z(:),rwrk8z(:)') CALL COM (2,' dimension iwrk8z(iiwk8z),rwrk8z(irwk8z)') CALL TEXT ('character*40 title') CALL TEXT ('logical plot,symm,fdiff,evcmpx,crankn,'// & 'noupdt,adapt,nodist,fillin,econ8z,ncon8z,restrt,gridid') IF (DP) THEN CALL TEXT & ('common/dtdp14/ sint8z(20),bint8z(20),slim8z(20),blim8z(20)') CALL TEXT ('common/dtdp15/ evlr8z,ev0r,evli8z,ev0i,evcmpx') CALL TEXT ('common/dtdp16/ p8z,evr8z(50),evi8z(50)') CALL TEXT ('common/dtdp19/ toler(neqnmx),adapt') CALL TEXT ('common/dtdp22/ nxa8z,nya8z,ifgr8z,kd8z,nbp8z') CALL TEXT ('common/dtdp23/ work8z(nxp8z*nyp8z+6)') CALL TEXT ('common/dtdp30/ econ8z,ncon8z') CALL TEXT ('common/dtdp46/ eps8z,cgtl8z,npmx8z,itype,near8z') CALL TEXT ('common/dtdp63/ amin8z(3*neqnmx),amax8z(3*neqnmx)') CALL TEXT ('common/dtdp65/ intri,iotri') CALL TEXT ('common/dtdp76/ mdim8z,nx18z,ny18z,xa,xb,ya,yb,'// & 'uout(0:nx,0:ny,3,neqn,0:nsave)') ELSE CALL TEXT & ('common/ tdp14/ sint8z(20),bint8z(20),slim8z(20),blim8z(20)') CALL TEXT ('common/ tdp15/ evlr8z,ev0r,evli8z,ev0i,evcmpx') CALL TEXT ('common/ tdp16/ p8z,evr8z(50),evi8z(50)') CALL TEXT ('common/ tdp19/ toler(neqnmx),adapt') CALL TEXT ('common/ tdp22/ nxa8z,nya8z,ifgr8z,kd8z,nbp8z') CALL TEXT ('common/ tdp23/ work8z(nxp8z*nyp8z+6)') CALL TEXT ('common/ tdp30/ econ8z,ncon8z') CALL TEXT ('common/ tdp46/ eps8z,cgtl8z,npmx8z,itype,near8z') CALL TEXT ('common/ tdp63/ amin8z(3*neqnmx),amax8z(3*neqnmx)') CALL TEXT ('common/ tdp65/ intri,iotri') CALL TEXT ('common/ tdp76/ mdim8z,nx18z,ny18z,xa,xb,ya,yb,'// & 'uout(0:nx,0:ny,3,neqn,0:nsave)') ENDIF CALL TEXT ('pi = 4.0*atan(1.d0)') CALL TEXT ('nxa8z = nxp8z') CALL TEXT ('nya8z = nyp8z') CALL TEXT ('nx18z = nx+1') CALL TEXT ('ny18z = ny+1') CALL TEXT ('mdim8z = 3') CALL TEXT ('kd8z = kdeg8z') CALL TEXT ('nbp8z = nbpt8z') CALL MESS (0,8) CALL TEXT ('NPROB = 1') CALL INVAR ('NPROB',.FALSE.) CALL STATE (IST999) WRITE (LUN,5) IST999 5 FORMAT (6X,'do ',I5,' iprob=1,nprob') CALL MESS (0,174) CALL GLOBP(LET1(5),36,LET2,52,FORB,80,PARNM,NPARN) CALL MESS (1,10) CALL IFYES (YES) LEVEL = 2 IF (YES) LEVEL = 3 CALL COM (2,' *******INITIAL TRIANGULATION OPTION') CALL MESS (1,175) CALL IREAD ('INTRI', INTRI, 1, 3) CALL COM (2,' *******SET IOTRI = 1 '// & 'TO DUMP FINAL TRIANGULATION TO FILE pde2d.tri') CALL TEXT ('IOTRI = 0') LUN = LPARAM IF (INTRI.EQ.1) THEN C INITIAL TRIANGULATION ON RECTANGULAR GRID CALL TEXT ('parameter (nv0=0,nt0=0,npgrid=0,nqgrid=0)') LUN = LFUNS CALL TEXT (' ') CALL TEXT (' ') CALL TEXT ('subroutine tran8z(p,q,x,y)') CALL PREC CALL TEXT ('x = p') CALL TEXT ('y = q') CALL TEXT ('return') CALL TEXT ('end') CALL TEXT (' ') CALL TEXT (' ') CALL TEXT ('subroutine xy8z(i8z,iarc8z,s,x,y,s0,sf)') CALL PREC CALL TEXT ('x = 0.0') CALL TEXT ('y = 0.0') CALL TEXT ('return') CALL TEXT ('end') LUN = LFORT CALL MESS (0,176) IF (DP) THEN CALL TEXT ('call dtdpwx(xgrid,nxgrid,0)') CALL TEXT ('call dtdpwx(ygrid,nygrid,0)') ELSE CALL TEXT ('call tdpwx(xgrid,nxgrid,0)') CALL TEXT ('call tdpwx(ygrid,nygrid,0)') ENDIF LUN = LPARAM CALL COM (1,'NXGRID = number of X-grid lines') CALL INPARM ('NXGRID', NXGRID, 2, INF) LUN = LFORT CALL COM (2, ' XGRID DEFINED') CALL INVAR ('XGRID(1)', .TRUE.) CALL INVEC ('XGRID', 2, NXGRID-1, .FALSE.) CALL INVAR ('XGRID(NXGRID)', .TRUE.) LUN = LPARAM CALL COM (1,'NYGRID = number of Y-grid lines') CALL INPARM ('NYGRID', NYGRID, 2, INF) LUN = LFORT CALL COM (2, ' YGRID DEFINED') CALL INVAR ('YGRID(1)', .TRUE.) CALL INVEC ('YGRID', 2, NYGRID-1, .FALSE.) CALL INVAR ('YGRID(NYGRID)', .TRUE.) IF (DP) THEN CALL TEXT ('call dtdpwx(xgrid,nxgrid,1)') CALL TEXT ('call dtdpwx(ygrid,nygrid,1)') ELSE CALL TEXT ('call tdpwx(xgrid,nxgrid,1)') CALL TEXT ('call tdpwx(ygrid,nygrid,1)') ENDIF NT0 = 4*(NXGRID-1)*(NYGRID-1) CALL MESS (0,177) CALL INVEC ('IXARC', 1, 2, .TRUE.) CALL INVEC ('IYARC', 1, 2, .TRUE.) ELSE IF (INTRI.EQ.2) THEN C INITIAL TRIANGULATION ON PARAMETERIZED REGION CALL TEXT ('parameter (nv0=0,nt0=0,nxgrid=0,nygrid=0)') LUN = LFUNS CALL TEXT (' ') CALL TEXT (' ') CALL TEXT ('subroutine tran8z(p,q,x,y)') CALL PREC WRITE (LUN,535) (PARNM(I),I=1,NPARN) CALL TEXT ('x = p') CALL TEXT ('y = q') CALL MESS (0,178) CALL IADD (3, 'X and Y') CALL INVAR ('X',.FALSE.) CALL INVAR ('Y',.FALSE.) CALL TEXT ('return') CALL TEXT ('end') CALL TEXT (' ') CALL TEXT (' ') CALL TEXT ('subroutine xy8z(i8z,iarc8z,s,x,y,s0,sf)') CALL PREC IF (DP) THEN CALL TEXT ('common /dtdp66/ p1,pn,q1,qn,ip1,ip2,iq1,iq2') ELSE CALL TEXT ('common / tdp66/ p1,pn,q1,qn,ip1,ip2,iq1,iq2') ENDIF CALL TEXT ('x = 0.0') CALL TEXT ('y = 0.0') CALL TEXT ('if (iarc8z.eq.ip1) call tran8z(p1,s,x,y)') CALL TEXT ('if (iarc8z.eq.ip2) call tran8z(pn,s,x,y)') CALL TEXT ('if (iarc8z.eq.iq1) call tran8z(s,q1,x,y)') CALL TEXT ('if (iarc8z.eq.iq2) call tran8z(s,qn,x,y)') CALL TEXT ('return') CALL TEXT ('end') LUN = LFORT CALL MESS (0,179) IF (DP) THEN CALL TEXT ('call dtdpwx(pgrid,npgrid,0)') CALL TEXT ('call dtdpwx(qgrid,nqgrid,0)') ELSE CALL TEXT ('call tdpwx(pgrid,npgrid,0)') CALL TEXT ('call tdpwx(qgrid,nqgrid,0)') ENDIF LUN = LPARAM CALL COM (1,'NPGRID = number of P-grid lines') CALL INPARM ('NPGRID', NPGRID, 2, INF) LUN = LFORT CALL COM (2, ' PGRID DEFINED') CALL INVAR ('PGRID(1)', .TRUE.) CALL INVEC ('PGRID', 2, NPGRID-1, .FALSE.) CALL INVAR ('PGRID(NPGRID)', .TRUE.) LUN = LPARAM CALL COM (1,'NQGRID = number of Q-grid lines') CALL INPARM ('NQGRID', NQGRID, 2, INF) LUN = LFORT CALL COM (2, ' QGRID DEFINED') CALL INVAR ('QGRID(1)', .TRUE.) CALL INVEC ('QGRID', 2, NQGRID-1, .FALSE.) CALL INVAR ('QGRID(NQGRID)', .TRUE.) IF (DP) THEN CALL TEXT ('call dtdpwx(pgrid,npgrid,1)') CALL TEXT ('call dtdpwx(qgrid,nqgrid,1)') ELSE CALL TEXT ('call tdpwx(pgrid,npgrid,1)') CALL TEXT ('call tdpwx(qgrid,nqgrid,1)') ENDIF NT0 = 4*(NPGRID-1)*(NQGRID-1) CALL MESS (0,180) CALL INVEC ('IPARC', 1, 2, .TRUE.) CALL INVEC ('IQARC', 1, 2, .TRUE.) ELSE C INITIAL TRIANGULATION ON GENERAL REGION CALL TEXT ('parameter (nxgrid=0,nygrid=0,npgrid=0,nqgrid=0)') LUN = LFORT CALL MESS (0,181) IF (DP) THEN CALL TEXT ('call dtdpwx(vxy,2*nv0,0)') ELSE CALL TEXT ('call tdpwx(vxy,2*nv0,0)') ENDIF LUN = LPARAM CALL COM (1, & 'NV0 = number of vertices in initial triangulation') CALL INPARM ('NV0', NV0, 4, INF) LUN = LFORT CALL INMAT ('VXY', 1, 2, 1, NV0, .FALSE.) CALL MESS (0,182) LUN = LPARAM CALL COM (1, & 'NT0 = number of triangles in initial triangulation') CALL INPARM ('NT0', NT0, 3, INF) LUN = LFORT DO 7 I=1,NT0 CALL INMAT ('IABC', 1, 3, I, I, .FALSE.) CALL INVEC ('IARC', I, I, .FALSE.) 7 CONTINUE IF (DP) THEN CALL TEXT ('call dtdpu(vxy,nv0,iabc,iarc,nt0)') ELSE CALL TEXT ('call tdpu(vxy,nv0,iabc,iarc,nt0)') ENDIF C PARAMETRIC EQUATIONS FOR CURVED BOUNDARIES LUN = LFUNS CALL TEXT (' ') CALL TEXT (' ') CALL TEXT ('subroutine tran8z(p,q,x,y)') CALL PREC CALL TEXT ('x = p') CALL TEXT ('y = q') CALL TEXT ('return') CALL TEXT ('end') CALL TEXT (' ') CALL TEXT (' ') CALL TEXT ('subroutine xy8z(i8z,iarc8z,s,x,y,s0,sf)') CALL PREC CALL TEXT ('dimension pxy(2,1000)') WRITE (LUN,535) (PARNM(I),I=1,NPARN) CALL TEXT ('x = 0.0') CALL TEXT ('y = 0.0') CALL MESS (1,183) CALL IFYES (YES) IF (YES) THEN C 10 CONTINUE CALL MESS (0,184) CALL IREAD ('IARC', IARC, -INF, INF) CALL TEXT (' if (iarc8z.eq.iarc) then') CALL MESS (1,185) CALL IFYES (YES) IF (YES) THEN CALL MESS (0,186) CALL IADD (3, 'S0,SF,X(S) and Y(S) (on this arc only)') CALL TEXT (' if (i8z.eq.0) then') CALL INVAR ('S0', .FALSE.) CALL INVAR ('SF', .FALSE.) CALL TEXT (' else') CALL INVAR ('X', .TRUE.) CALL INVAR ('Y', .TRUE.) CALL TEXT (' endif') ELSE CALL MESS (0,187) CALL IADD (3, 'PXY (on this arc only)') CALL TEXT (' if (i8z.eq.1) then') CALL IREAD ('NPTS', NPTS, 2, 1000) CALL INMAT ('PXY', 1, 2, 1, NPTS, .TRUE.) IF (DP) THEN CALL TEXT ('call dtdpw(npts, pxy, s, x, y)') ELSE CALL TEXT ('call tdpw(npts, pxy, s, x, y)') ENDIF CALL TEXT (' endif') ENDIF CALL TEXT (' endif') CALL MESS (1,188) CALL IFYES (YES) IF (YES) GO TO 10 C ENDIF CALL TEXT ('return') CALL TEXT ('end') ENDIF LUN = LFORT CALL MESS (0,189) CALL IREAD ('NTF', NTF, NT0, INF) LUN = LFUNS CALL TEXT (' ') CALL TEXT (' ') CALL TEXT ('subroutine dis8z(x,y,ktri,triden,shape)') CALL PREC CALL TEXT ('logical adapt') WRITE (LUN,535) (PARNM(I),I=1,NPARN) CALL MESS (0,190) CALL TEXT ('TRIDEN = 1.0') CALL IADD (3, 'TRIDEN and SHAPE') CALL INVAR ('TRIDEN', .FALSE.) CALL MESS (0,191) CALL IFYES (YES) IF (YES) THEN CALL TEXT ('ADAPT = .TRUE.') ELSE CALL TEXT ('ADAPT = .FALSE.') ENDIF CALL COM (2,' ') CALL TEXT ('EXAG = 1.5') IF (DP) THEN CALL TEXT & ('if (adapt) triden = dtdpgr2(x,y,triden**(1.0/exag))**exag') ELSE CALL TEXT & ('if (adapt) triden = tdpgr2(x,y,triden**(1.0/exag))**exag') ENDIF CALL MESS (0,192) CALL TEXT ('SHAPE = 1.0') CALL INVAR ('SHAPE', .FALSE.) CALL TEXT ('return') CALL TEXT ('end') LUN = LFORT CALL MESS (0,193) CALL IREAD ('ISOLVE', ISOLVE, 1, ISMX2D) CALL MESS (0,194) 15 CALL IREAD ('IDEG', IDEG, -4, 4) IF (IDEG.EQ.0) THEN WRITE (INTOUT,20) 20 FORMAT ('|---- Illegal input') GO TO 15 ENDIF C IDENTIFY TYPE OF PDE CALL MESS (1,11) CALL IREAD (' ', ITYPE, 1, 3) ELL = ITYPE .EQ. 1 PARA = ITYPE .EQ. 2 EIGEN = ITYPE .EQ. 3 IF (EIGEN) THEN C EIGENVALUE PROBLEM SOLVED CALL COM (2, ' *******EIGENVALUE PROBLEM') CALL MESS (0,12) CALL PAWS CALL TEXT ('ITYPE = 3') CALL COM (2,' ') CALL COM (2,' P8Z = 0.0') LINEAR = .TRUE. CALL TEXT ('t0 = 0.0') CALL TEXT ('dt = 1.0') CALL TEXT ('crankn = .false.') CALL TEXT ('noupdt = .true.') CALL MESS (0,13) CALL IFYES (EVCMPX) IF (.NOT.EVCMPX) THEN CALL TEXT ('EVCMPX = .FALSE.') CALL MESS (0,14) CALL TEXT ('EV0R = 0.0') CALL INVAR ('EV0R', .FALSE.) ELSE CALL TEXT ('EVCMPX = .TRUE.') CALL MESS (0,15) CALL TEXT ('EV0R = 0.0') CALL TEXT ('EV0I = 0.0') CALL INVAR ('EV0R', .FALSE.) CALL INVAR ('EV0I', .FALSE.) ENDIF CALL MESS (0,16) CALL TEXT ('NSTEPS = 25') CALL INVAR ('NSTEPS',.FALSE.) ELSE IF (PARA) THEN C TIME DEPENDENT PROBLEM SOLVED CALL COM (2, ' *******TIME-DEPENDENT PROBLEM') CALL TEXT ('itype = 2') CALL MESS (0,17) CALL TEXT ('T0 = 0.0') CALL INVAR ('T0', .FALSE.) CALL INVAR ('TF', .TRUE.) CALL MESS (1,18) CALL IFYES (LINEAR) CALL MESS (0,19) CALL IFYES (YES) IF (YES) THEN CALL TEXT ('ADAPT = .TRUE.') CALL TEXT ('TOLER(1) = 0.01') CALL INVAR ('TOLER(1)', .FALSE.) IF (LINEAR) CALL MESS (2,20) CALL TEXT ('NOUPDT = .FALSE.') CALL MESS (0,21) ELSE CALL TEXT ('ADAPT = .FALSE.') CALL TEXT ('TOLER(1) = 0.01') IF (LINEAR) THEN CALL MESS (0,20) CALL IFYES (YES) IF (YES) THEN CALL TEXT ('NOUPDT = .TRUE.') ELSE CALL TEXT ('NOUPDT = .FALSE.') ENDIF ELSE CALL TEXT ('NOUPDT = .FALSE.') ENDIF CALL MESS (0,22) ENDIF CALL INVAR ('NSTEPS',.TRUE.) CALL TEXT ('dt = (tf-t0)/max(nsteps,1)') CALL MESS (0,65) CALL IFYES (YES) IF (YES) THEN CALL TEXT ('CRANKN = .TRUE.') ELSE CALL TEXT ('CRANKN = .FALSE.') ENDIF ELSE C STEADY STATE PROBLEM SOLVED CALL COM (2, ' *******STEADY-STATE PROBLEM') CALL TEXT ('itype = 1') CALL TEXT ('t0 = 0.0') CALL TEXT ('dt = 1.0') CALL TEXT ('crankn = .false.') CALL TEXT ('noupdt = .false.') CALL MESS (1,18) CALL IFYES (LINEAR) IF (LINEAR) THEN CALL COM (2, ' Number of Newton iterations') CALL TEXT ('NSTEPS = 1') ELSE CALL MESS (0,24) CALL TEXT ('NSTEPS = 15') CALL INVAR ('NSTEPS',.FALSE.) ENDIF ENDIF LUN = LPARAM CALL MESS (0,25) CALL INPARM ('NEQN', NEQN, 1, NEQNMX) LUN = LFORT CALL MESS (1,195) CALL VARNAM(LET1,28,LET2,40,FORB,40,NEQN) IND = MIN(NEQN-1,3) C SYMMETRIC? IF (EIGEN) THEN CALL MESS (0,196 + IND) ELSE IF (ELL) THEN CALL MESS (0,200 + IND) ELSE IF (PARA) THEN CALL MESS (0,204 + IND) ENDIF CALL IFYES (SYMM) IF (SYMM) THEN CALL TEXT ('SYMM = .TRUE.') ELSE CALL TEXT ('SYMM = .FALSE.') ENDIF C FINITE DIFFERENCE JACOBIAN? IF (LINEAR) THEN FDIFF = .FALSE. ELSE CALL MESS (0,27) CALL IFYES (FDIFF) ENDIF IF (FDIFF) THEN CALL TEXT ('FDIFF = .TRUE.') ELSE CALL TEXT ('FDIFF = .FALSE.') ENDIF C CALCULATE STORAGE REQUIREMENTS LUN = LPARAM CALL COM (2, ' DIMENSIONS OF WORK ARRAYS') IRWK = 1 IIWK = 1 CALL COM (2, ' SET TO 1 FOR AUTOMATIC ALLOCATION') WRITE (LUN,110) IRWK,IIWK 110 FORMAT (6X,'PARAMETER (IRWK8Z=',I12,')',/, 6X,'PARAMETER (IIWK8Z=' &,I12,')') CALL TEXT ('PARAMETER (NXP8Z=101,NYP8Z=101,KDEG8Z=1,NBPT8Z=51)') C SUBROUTINE PDES8Z LUN = LFUNS CALL TEXT (' ') CALL TEXT (' ') CALL TEXT ('subroutine pdes8z'// & '(yd8z,i8z,j8z,kint8z,idel8z,jdel8z,x,y,ktri,t)') CALL PREC WRITE (LUN,120) NEQNMX 120 FORMAT (6X,'parameter (neqnmx=',I4,')') IF (EIGEN) WRITE (LUN,121) NEQN 121 FORMAT (6X,'parameter (NEQN=',I4,')') WRITE (LUN,125) NDELMX 125 FORMAT (6X,'parameter (ndelmx=',I4,')') CALL COM (2, ' un8z(1,I),un8z(2,I),un8z(3,I) hold'// & ' the (rarely used) values') CALL COM (2, ' of UI,UIx,UIy from the previous'// & ' iteration or time step') IF (DP) THEN CALL TEXT ('common/dtdp4/un8z(3,neqnmx),uu8z(3,neqnmx)') CALL TEXT ('common/dtdp17/normx,normy,iarc') CALL TEXT('double precision normx,normy,delamp(ndelmx,neqnmx)') ELSE CALL TEXT ('common/ tdp4/un8z(3,neqnmx),uu8z(3,neqnmx)') CALL TEXT ('common/ tdp17/normx,normy,iarc') CALL TEXT('real normx,normy,delamp(ndelmx,neqnmx)') ENDIF IF (EIGEN.AND.(NEQN.GT.1)) CALL TEXT('dimension rho(neqn,neqn)') WRITE (LUN,535) (PARNM(I),I=1,NPARN) DO 160 IEQ = 1,NEQN WRITE (LUN,130) UNK(IEQ)(1:NUNK(IEQ)),IEQ 130 FORMAT(6X,A,' = uu8z(1,',I2,')') WRITE (LUN,140) UNK(IEQ)(1:NUNK(IEQ)),IEQ 140 FORMAT(6X,A,'x = uu8z(2,',I2,')') WRITE (LUN,150) UNK(IEQ)(1:NUNK(IEQ)),IEQ 150 FORMAT(6X,A,'y = uu8z(3,',I2,')') WRITE (LUN,155) UNK(IEQ)(1:NUNK(IEQ)),UNK(IEQ)(1:NUNK(IEQ)), & UNK(IEQ)(1:NUNK(IEQ)) 155 FORMAT(6X,A,'norm = ',A,'x*normx + ',A,'y*normy') 160 CONTINUE CALL TEXT (' if (i8z.eq.0) then') CALL TEXT ('yd8z = 0.0') LUN = LFORT CALL MESS (0,28) CALL IREAD ('NINT', NINT, 0, 20) LUN = LFUNS IF (NINT.GT.0) THEN CALL MESS (0,208 + IND) CALL IADD (3, 'the integrals') DO 170 I=1,NINT CALL VECFUN('INTEGRAL',I,NINT,I,'yd8z',0,'kint8z') 170 CONTINUE ELSE CALL MESS (2,208 + IND) WRITE (LUN,180) 180 FORMAT ('C',50X,'INTEGRAL1 DEFINED',/, & 'C if (kint8z.eq.1) yd8z =',/, & 'C & [DEFAULT SELECTED, DEFINITION COMMENTED OUT]') ENDIF LUN = LFORT CALL MESS (0,74) CALL IREAD ('NBINT', NBINT, 0, 20) LUN = LFUNS IF (NBINT.GT.0) THEN CALL MESS (0,212 + IND) CALL IADD (3, 'the boundary integrals') DO 190 I=1,NBINT CALL VECFUN('BND. INTEGRAL',I,NBINT,(-I),'yd8z',0,'kint8z') 190 CONTINUE ELSE CALL MESS (2,212 + IND) WRITE (LUN,200) 200 FORMAT ('C',50X,'BND. INTEGRAL1 DEFINED',/, & 'C if (kint8z.eq.-1) yd8z =',/, & 'C & [DEFAULT SELECTED, DEFINITION COMMENTED OUT]') ENDIF LUN = LFORT IF (.NOT.EIGEN) THEN CALL MESS (1,216) CALL IFYES(YES) IF (YES) THEN CALL MESS (0,217) CALL IREAD ('NDEL', NDEL, 1, NDELMX) DO 210 I=1,NDEL CALL SPACER CALL INVEC ('XD0', I, I, .TRUE.) CALL INVEC ('YD0', I, I, .TRUE.) 210 CONTINUE LUN = LFUNS CALL TEXT (' if (kint8z.eq.0) then') CALL MESS (0,218) CALL IADD (3, 'the Delta function amplitudes') CALL INMAT ('DELAMP', 1, NDEL, 1, NEQN, .TRUE.) CALL TEXT ('yd8z = delamp(idel8z,jdel8z)') CALL TEXT (' endif') ELSE CALL TEXT ('ndel = 0') ENDIF ELSE CALL TEXT ('ndel = 0') ENDIF LUN = LFUNS CALL TEXT (' else') IF (EIGEN) THEN CALL MESS (0,219 + IND) CALL IADD (2, 'these coefficients') ELSE IF (ELL) THEN CALL MESS (0,223 + IND) CALL IADD (2, 'these coefficients') ELSE IF (PARA) THEN CALL MESS (0,227 + IND) CALL IADD (2, 'these coefficients') ENDIF CALL TEXT (' if (j8z.eq.0) then') CALL TEXT ('yd8z = 0.0') C PDES DEFINED DO 220 I = 1,NEQN II = 3*(I-1) IF (PARA) THEN DO 215 J = 1,NEQN LL = 100*I+J IF (NEQN.EQ.1) THEN CALL VECFUN ('C',1,1,(-LL),'yd8z',2,'i8z') ELSE IF (NEQN.LE.9) THEN WRITE (CNUM6,213) I,J 213 FORMAT ('C(',I1,',',I1,')') CALL VECFUN (CNUM6,1,1,(-LL),'yd8z',2,'i8z') ELSE WRITE (CNUM8,214) I,J 214 FORMAT ('C(',I2,',',I2,')') CALL VECFUN (CNUM8,1,1,(-LL),'yd8z',2,'i8z') ENDIF 215 CONTINUE ENDIF CALL VECFUN('F', I, NEQN, II+1, 'yd8z', 2,'i8z') CALL VECFUN('A', I, NEQN, II+2, 'yd8z', 2,'i8z') CALL VECFUN('B', I, NEQN, II+3, 'yd8z', 2,'i8z') IF (EIGEN) THEN IF (NEQN .EQ. 1) THEN CALL COM (2, & ' RHO DEFINED') CALL INVAR ('RHO', .TRUE.) ELSE CALL COM (2, & ' RHO DEFINED') CALL INMAT ('RHO', I, I, 1, NEQN, .TRUE.) ENDIF ENDIF 220 CONTINUE IF (EIGEN) THEN IF (DP) THEN CALL TEXT ('call dtdpza (yd8z,i8z,uu8z,un8z,rho,3,neqn)') ELSE CALL TEXT ('call tdpza (yd8z,i8z,uu8z,un8z,rho,3,neqn)') ENDIF ENDIF CALL TEXT (' else') IF ( .NOT.LINEAR .AND. .NOT.FDIFF) THEN DO 240 I = 1,NEQN DO 230 J = 1,NEQN II = 3*(I-1) JJ = 3*(J-1) CALL MATFUN('F', I, NEQN, UNK(J)(1:NUNK(J)), & II + 1, JJ + 1, 'yd8z', 0) CALL MATFUN('F', I, NEQN, UNK(J)(1:NUNK(J))//'x', & II + 1, JJ + 2, 'yd8z', 0) CALL MATFUN('F', I, NEQN, UNK(J)(1:NUNK(J))//'y', & II + 1, JJ + 3, 'yd8z', 0) CALL MATFUN('A', I, NEQN, UNK(J)(1:NUNK(J)), & II + 2, JJ + 1, 'yd8z', 0) CALL MATFUN('A', I, NEQN, UNK(J)(1:NUNK(J))//'x', & II + 2, JJ + 2, 'yd8z', 0) CALL MATFUN('A', I, NEQN, UNK(J)(1:NUNK(J))//'y', & II + 2, JJ + 3, 'yd8z', 0) CALL MATFUN('B', I, NEQN, UNK(J)(1:NUNK(J)), & II + 3, JJ + 1, 'yd8z', 0) CALL MATFUN('B', I, NEQN, UNK(J)(1:NUNK(J))//'x', & II + 3, JJ + 2, 'yd8z', 0) CALL MATFUN('B', I, NEQN, UNK(J)(1:NUNK(J))//'y', & II + 3, JJ + 3, 'yd8z', 0) 230 CONTINUE 240 CONTINUE ENDIF CALL TEXT (' endif') CALL TEXT (' endif') CALL TEXT ('return') CALL TEXT ('end') C INITIAL VALUES SPECIFIED CALL TEXT (' ') CALL TEXT (' ') CALL TEXT ('function u8z(i8z,x,y,ktri,t0)') CALL PREC WRITE (LUN,535) (PARNM(I),I=1,NPARN) IF (EIGEN) THEN IF (DP) THEN CALL TEXT ('u8z = dtdpxx()') ELSE CALL TEXT ('u8z = tdpxx()') ENDIF ELSE CALL TEXT ('u8z = 0.0') ENDIF IF ( .NOT.ELL .OR. .NOT.LINEAR) THEN IF (EIGEN) CALL MESS (0,231) IF (ELL) CALL MESS (0,232) IF (PARA) CALL MESS (0,233) CALL IADD (3, 'the initial values') DO 250 I = 1,NEQN IF (EIGEN) THEN CALL VECFUN (UNK(I)(1:NUNK(I))//'0',0,1,I, & 'u8z',1,'i8z') ELSE CALL VECFUN (UNK(I)(1:NUNK(I))//'0',0,1,I, & 'u8z',2,'i8z') ENDIF 250 CONTINUE LUN = LFORT CALL MESS (0,48) CALL IFYES(RESTRT) IF (RESTRT) THEN CALL TEXT ('RESTRT = .TRUE.') CALL MESS (0,97) CALL IFYES(YES) IF (YES) THEN CALL TEXT ('GRIDID = .TRUE.') ELSE CALL TEXT ('GRIDID = .FALSE.') ENDIF ELSE CALL TEXT ('RESTRT = .FALSE.') CALL COM (2,'GRIDID = .FALSE. IF FINITE ELEMENT'// & ' GRID CHANGES BETWEEN DUMP, RESTART') CALL TEXT ('GRIDID = .TRUE.') ENDIF ELSE LUN = LFORT CALL TEXT ('RESTRT = .FALSE.') CALL TEXT ('GRIDID = .TRUE.') ENDIF LUN = LFUNS CALL TEXT ('return') CALL TEXT ('end') C FIXED BOUNDARY CONDITIONS DEFINED CALL TEXT (' ') CALL TEXT (' ') CALL TEXT ('function fb8z(i8z,iarc8z,ktri,s,x,y,t)') CALL PREC WRITE (LUN,535) (PARNM(I),I=1,NPARN) CALL TEXT ('fb8z = 0.0') IF (EIGEN) THEN CALL MESS (0,100) ELSE CALL MESS (1,234) CALL IFYES (YES) IF (YES) THEN C 260 CONTINUE CALL MESS (0,235) CALL IREAD ('IARC', IARC, -INF, -1) CALL TEXT (' if (iarc8z.eq.iarc) then') CALL MESS (0,236 + IND) CALL IADD (3, 'the boundary conditions (on this arc only)') DO 270 I = 1,NEQN CALL VECFUN ('FB', I, NEQN, I, 'fb8z', 2, 'i8z') 270 CONTINUE CALL TEXT (' endif') CALL MESS (1,240) CALL IFYES (YES) IF (YES) GO TO 260 C ELSE CALL COM (2, & ' NO BOUNDARY CONDITIONS DEFINED ON NEGATIVE ARCS.') CALL COM (2, & ' TO ADD BCs FOR NEGATIVE ARCS, USE BLOCK BELOW AS MODEL') CALL TEXT ('IARC = 0') CALL TEXT (' if (iarc8z.eq.iarc) then') CALL MESS (2,236 + IND) DO 275 I = 1,NEQN CALL VECFUN ('FB', I, NEQN, I, 'fb8z', 3, 'i8z') 275 CONTINUE CALL TEXT (' endif') ENDIF ENDIF CALL TEXT ('return') CALL TEXT ('end') C FREE BOUNDARY CONDITIONS DEFINED CALL TEXT (' ') CALL TEXT (' ') CALL TEXT ('subroutine gb8z(gd8z,i8z,j8z,iarc8z,ktri,s,x,y,t)') CALL PREC WRITE (LUN,120) NEQNMX CALL COM (2, ' un8z(1,I),un8z(2,I),un8z(3,I) hold'// & ' the (rarely used) values') CALL COM (2, ' of UI,UIx,UIy from the previous'// & ' iteration or time step.') CALL COM (2, ' (normx,normy) is the (rarely used)'// & ' unit outward normal vector') IF (DP) THEN CALL TEXT ('common/dtdp4/un8z(3,neqnmx),uu8z(neqnmx,3)') CALL TEXT ('common/dtdp17/normx,normy,ibarc8z') CALL TEXT ('common/dtdp49/bign8z') CALL TEXT ('double precision normx,normy') ELSE CALL TEXT ('common/ tdp4/un8z(3,neqnmx),uu8z(neqnmx,3)') CALL TEXT ('common/ tdp17/normx,normy,ibarc8z') CALL TEXT ('common/ tdp49/bign8z') CALL TEXT ('real normx,normy') ENDIF WRITE (LUN,535) (PARNM(I),I=1,NPARN) CALL TEXT ('zero(f8z) = bign8z*f8z') DO 290 IEQ = 1,NEQN WRITE (LUN,280) UNK(IEQ)(1:NUNK(IEQ)),IEQ 280 FORMAT(6X,A,' = uu8z(',I2,',1)') WRITE (LUN,281) UNK(IEQ)(1:NUNK(IEQ)),IEQ 281 FORMAT(6X,A,'x = uu8z(',I2,',2)') WRITE (LUN,282) UNK(IEQ)(1:NUNK(IEQ)),IEQ 282 FORMAT(6X,A,'y = uu8z(',I2,',3)') 290 CONTINUE CALL TEXT ('if (j8z.eq.0) gd8z = 0.0') CALL MESS (1,241) CALL IFYES (YES) IF (YES) THEN C 300 CONTINUE CALL MESS (0,242) CALL IREAD ('IARC', IARC, 1, 999) CALL TEXT (' if (iarc8z.eq.iarc) then') CALL MESS (0,243 + IND) CALL IADD (3, 'the boundary conditions (on this arc only)') CALL TEXT (' if (j8z.eq.0) then') DO 310 I = 1,NEQN CALL VECFUN ('GB', I, NEQN, I, 'gd8z', 2, 'i8z') 310 CONTINUE CALL TEXT (' else') IF ( .NOT.LINEAR .AND. .NOT.FDIFF) THEN DO 330 I = 1,NEQN DO 320 J = 1,NEQN CALL MATFUN ('GB', I, NEQN, UNK(J)(1:NUNK(J)), & I, J, 'gd8z', 0) CALL MATFUN ('GB', I, NEQN, UNK(J)(1:NUNK(J))//'x', & I, 100+J, 'gd8z', 0) CALL MATFUN ('GB', I, NEQN, UNK(J)(1:NUNK(J))//'y', & I, 200+J, 'gd8z', 0) 320 CONTINUE 330 CONTINUE ENDIF CALL TEXT (' endif') CALL TEXT (' endif') CALL MESS (1,247) CALL IFYES (YES) IF (YES) GO TO 300 C ELSE CALL COM (2, & ' NO BOUNDARY CONDITIONS DEFINED ON POSITIVE ARCS.') CALL COM (2, & ' TO ADD BCs FOR POSITIVE ARCS, USE BLOCK BELOW AS MODEL') CALL TEXT ('IARC = 0') CALL TEXT (' if (iarc8z.eq.iarc) then') CALL MESS (2,243 + IND) CALL TEXT (' if (j8z.eq.0) then') DO 331 I = 1,NEQN CALL VECFUN ('GB', I, NEQN, I, 'gd8z', 3, 'i8z') 331 CONTINUE CALL TEXT (' else') IF ( .NOT.LINEAR .AND. .NOT.FDIFF) THEN DO 333 I = 1,NEQN DO 332 J = 1,NEQN CALL MATFUN ('GB', I, NEQN, UNK(J)(1:NUNK(J)), & I, J, 'gd8z', 1) CALL MATFUN ('GB', I, NEQN, UNK(J)(1:NUNK(J))//'x', & I, 100+J, 'gd8z', 1) CALL MATFUN ('GB', I, NEQN, UNK(J)(1:NUNK(J))//'y', & I, 200+J, 'gd8z', 1) 332 CONTINUE 333 CONTINUE ENDIF CALL TEXT (' endif') CALL TEXT (' endif') ENDIF CALL TEXT ('return') CALL TEXT ('end') C OUTPUT MODIFICATION FUNCTIONS DEFINED LUN = LFUNS CALL TEXT (' ') CALL TEXT (' ') CALL TEXT ('subroutine pmod8z(x,y,ktri,t,a,b)') CALL PREC WRITE (LUN,120) NEQNMX IF (DP) THEN CALL TEXT ('common/dtdp4/un8z(3,neqnmx),uu8z(3,neqnmx)') CALL TEXT ('common/dtdp6/upr8z(3,neqnmx),uab8z(3,neqnmx)') CALL TEXT & ('common/dtdp9/uprint(neqnmx),aprint(neqnmx),bprint(neqnmx)') CALL TEXT & ('common/dtdp14/sint(20),bint(20),slim8z(20),blim8z(20)') ELSE CALL TEXT ('common/ tdp4/un8z(3,neqnmx),uu8z(3,neqnmx)') CALL TEXT ('common/ tdp6/upr8z(3,neqnmx),uab8z(3,neqnmx)') CALL TEXT & ('common/ tdp9/uprint(neqnmx),aprint(neqnmx),bprint(neqnmx)') CALL TEXT & ('common/ tdp14/sint(20),bint(20),slim8z(20),blim8z(20)') ENDIF WRITE (LUN,535) (PARNM(I),I=1,NPARN) DO 380 IEQ = 1,NEQN WRITE (LUN,130) UNK(IEQ)(1:NUNK(IEQ)),IEQ WRITE (LUN,140) UNK(IEQ)(1:NUNK(IEQ)),IEQ WRITE (LUN,150) UNK(IEQ)(1:NUNK(IEQ)),IEQ IF (IEQ.LE.9) THEN WRITE (LUN,340) IEQ, IEQ 340 FORMAT(6X,'a',I1,' = upr8z(2,',I2,')') WRITE (LUN,350) IEQ, IEQ 350 FORMAT(6X,'b',I1,' = upr8z(3,',I2,')') ELSE WRITE (LUN,360) IEQ, IEQ 360 FORMAT(6X,'a',I2,' = upr8z(2,',I2,')') WRITE (LUN,370) IEQ, IEQ 370 FORMAT(6X,'b',I2,' = upr8z(3,',I2,')') ENDIF 380 CONTINUE CALL MESS (0,248 + IND) CALL IADD (3, 'these variables') CALL COM (2, ' DEFINE UPRINT(*),APRINT(*),'// & 'BPRINT(*) HERE:') DO 400 I=1,NEQN WRITE (INTOUT,381) UNK(I)(1:NUNK(I)) 381 FORMAT (' Replace ',A,' for postprocessing?') CALL INVEC ('UPRINT', I, I, .FALSE.) IF (NEQN.EQ.1) THEN WRITE (INTOUT,382) 382 FORMAT (' Replace A for postprocessing?') ELSE IF (I.LE.9) THEN WRITE (INTOUT,383) I 383 FORMAT (' Replace A',I1,' for postprocessing?') ELSE WRITE (INTOUT,384) I 384 FORMAT (' Replace A',I2,' for postprocessing?') ENDIF CALL INVEC ('APRINT', I, I, .FALSE.) IF (NEQN.EQ.1) THEN WRITE (INTOUT,385) 385 FORMAT (' Replace B for postprocessing?') ELSE IF (I.LE.9) THEN WRITE (INTOUT,386) I 386 FORMAT (' Replace B',I1,' for postprocessing?') ELSE WRITE (INTOUT,387) I 387 FORMAT (' Replace B',I2,' for postprocessing?') ENDIF CALL INVEC ('BPRINT', I, I, .FALSE.) 400 CONTINUE CALL TEXT ('return') CALL TEXT ('end') C OUTPUT PARAMETERS LUN = LPARAM CALL MESS (0,252) CALL INPARM ('NX', NX, 1, INF) CALL INPARM ('NY', NY, 0, INF) LUN = LFORT IF (NY.EQ.0) THEN CALL TEXT ('npts8z = nx+1') CALL MESS (0,253) CALL IADD (0, ' ') ELSE CALL MESS (0,254) CALL COM (2, ' defaults for xa,xb,ya,yb') IF (INTRI.EQ.2) THEN IF (DP) THEN CALL TEXT ('call dtdpv (pgrid,npgrid,qgrid,'// & 'nqgrid,vxy,nv0,iarc,nt0,xa,xb,ya,yb)') ELSE CALL TEXT ('call tdpv (pgrid,npgrid,qgrid,'// & 'nqgrid,vxy,nv0,iarc,nt0,xa,xb,ya,yb)') ENDIF ELSE IF (DP) THEN CALL TEXT ('call dtdpv (xgrid,nxgrid,ygrid,'// & 'nygrid,vxy,nv0,iarc,nt0,xa,xb,ya,yb)') ELSE CALL TEXT ('call tdpv (xgrid,nxgrid,ygrid,'// & 'nygrid,vxy,nv0,iarc,nt0,xa,xb,ya,yb)') ENDIF ENDIF CALL COM (2, ' DEFINE XA,XB,YA,YB IMMEDIATELY BELOW:') CALL INVAR ('XA', .FALSE.) CALL INVAR ('XB', .FALSE.) CALL INVAR ('YA', .FALSE.) CALL INVAR ('YB', .FALSE.) IF (DP) THEN CALL TEXT ('call dtdpx2(nx,ny,xa,xb,ya,yb,hx8z,hy8z,'// & 'xout8z,yout8z,npts8z)') ELSE CALL TEXT ('call tdpx2(nx,ny,xa,xb,ya,yb,hx8z,hy8z,'// & 'xout8z,yout8z,npts8z)') ENDIF ENDIF IF (PARA) THEN LUN = LPARAM CALL MESS (0,53) CALL INPARM ('NSAVE', NSAVE, 1, INF) LUN = LFORT ELSE LUN = LPARAM NSAVE = 1 CALL TEXT ('PARAMETER (NSAVE = 1)') LUN = LFORT CALL COM (2, ' SOLUTION SAVED EVERY NOUT ITERATIONS') CALL TEXT ('NOUT = NSTEPS') ENDIF IF (DP) THEN CALL TEXT ('call dtdpzz(ntf,ideg,isolve,symm,neqn,'// & 'ii8z,ir8z)') ELSE CALL TEXT ('call tdpzz(ntf,ideg,isolve,symm,neqn,'// & 'ii8z,ir8z)') ENDIF CALL TEXT ('if (iiwk8z.gt.1) ii8z = iiwk8z') CALL TEXT ('if (irwk8z.gt.1) ir8z = irwk8z') CALL COM (2, ' *******allocate workspace') CALL TEXT ('allocate (iwrk8z(ii8z),rwrk8z(ir8z))') CALL COM (2, ' *******DRAW TRIANGULATION PLOTS (OVER') CALL COM (2, ' *******RECTANGLE (XA,XB) x (YA,YB))?') CALL TEXT ('PLOT = .TRUE.') CALL COM (2, ' *******call pde solver') IF (INTRI.EQ.2) THEN IF (DP) THEN CALL TEXT ('call dtdp2x(pgrid, npgrid, qgrid, nqgrid, iparc,'// & ' iqarc, vxy, nv0, iabc, nt0, iarc, restrt, gridid,'// & ' neqn, ntf, ideg, isolve, nsteps, nout, t0, dt,'// & ' plot, symm, fdiff, itype, nint, nbint, ndel,'// & ' xd0, yd0, crankn, noupdt, xbd8z, ybd8z, nbd8z,'// & ' xout8z, yout8z, uout, inrg8z, npts8z, ny, tout8z,'// & ' nsave, iwrk8z, ii8z, rwrk8z, ir8z)') ELSE CALL TEXT ('call tdp2x(pgrid, npgrid, qgrid, nqgrid, iparc,'// & ' iqarc, vxy, nv0, iabc, nt0, iarc, restrt, gridid,'// & ' neqn, ntf, ideg, isolve, nsteps, nout, t0, dt,'// & ' plot, symm, fdiff, itype, nint, nbint, ndel,'// & ' xd0, yd0, crankn, noupdt, xbd8z, ybd8z, nbd8z,'// & ' xout8z, yout8z, uout, inrg8z, npts8z, ny, tout8z,'// & ' nsave, iwrk8z, ii8z, rwrk8z, ir8z)') ENDIF ELSE IF (DP) THEN CALL TEXT ('call dtdp2x(xgrid, nxgrid, ygrid, nygrid, ixarc,'// & ' iyarc, vxy, nv0, iabc, nt0, iarc, restrt, gridid,'// & ' neqn, ntf, ideg, isolve, nsteps, nout, t0, dt,'// & ' plot, symm, fdiff, itype, nint, nbint, ndel,'// & ' xd0, yd0, crankn, noupdt, xbd8z, ybd8z, nbd8z,'// & ' xout8z, yout8z, uout, inrg8z, npts8z, ny, tout8z,'// & ' nsave, iwrk8z, ii8z, rwrk8z, ir8z)') ELSE CALL TEXT ('call tdp2x(xgrid, nxgrid, ygrid, nygrid, ixarc,'// & ' iyarc, vxy, nv0, iabc, nt0, iarc, restrt, gridid,'// & ' neqn, ntf, ideg, isolve, nsteps, nout, t0, dt,'// & ' plot, symm, fdiff, itype, nint, nbint, ndel,'// & ' xd0, yd0, crankn, noupdt, xbd8z, ybd8z, nbd8z,'// & ' xout8z, yout8z, uout, inrg8z, npts8z, ny, tout8z,'// & ' nsave, iwrk8z, ii8z, rwrk8z, ir8z)') ENDIF ENDIF CALL TEXT ('deallocate (iwrk8z,rwrk8z)') IF (EIGEN) THEN WRITE (LUN,401) IST999 401 FORMAT (6X,'if (itype.eq.4) go to ',I5) CALL COM (2, & ' *******UNCOMMENT TO POSTPROCESS ONLY IF CONVERGED') WRITE (LUN,405) IST999 405 FORMAT ('C',6X,'IF (.NOT.ECON8Z) GO TO ',I5) ENDIF IF (ELL.AND.(.NOT.LINEAR)) THEN CALL COM (2, & ' *******UNCOMMENT TO POSTPROCESS ONLY IF CONVERGED') WRITE (LUN,406) IST999 406 FORMAT ('C',6X,'IF (.NOT.NCON8Z) GO TO ',I5) ENDIF IF (DP) THEN CALL COM (2, & ' *******read from restart file to array ures8z') CALL COM (2,' call dtdpr2(1,xres8z,nxp8z,yres8z,'// & 'nyp8z,ures8z,neqn)') CALL COM (2, & ' *******write array ures8z back to restart file') CALL COM (2,' call dtdpr2(2,xres8z,nxp8z,yres8z,'// & 'nyp8z,ures8z,neqn)') ELSE CALL COM (2, & ' *******read from restart file to array ures8z') CALL COM (2,' call tdpr2(1,xres8z,nxp8z,yres8z,'// & 'nyp8z,ures8z,neqn)') CALL COM (2, & ' *******write array ures8z back to restart file') CALL COM (2,' call tdpr2(2,xres8z,nxp8z,yres8z,'// & 'nyp8z,ures8z,neqn)') ENDIF CALL COM (2,' *******call user-written postprocessor') CALL TEXT ('call '// &'postpr(tout8z,nsave,xout8z,yout8z,inrg8z,nx,ny,uout,neqn)') 410 CONTINUE CALL MESS (1,255) IPLIM = 6 IF (NEQN .EQ. 1) IPLIM = 5 IF (NY .EQ. 0) IPLIM = 1 CALL IREAD (' ', IPLOT, 0, IPLIM) IF (IPLOT .EQ. 0) THEN GO TO 440 ELSE IF (IPLOT .EQ. 1) THEN C TABLE OF VALUES AT OUTPUT POINTS CALL COM (2, ' *******TABULAR OUTPUT') CALL MESS (0,256 + IND) CALL IREAD ('IVAR', IVAR, 1, 3*NEQN) CALL TEXT ('ivara8z = mod(ivar-1,3)+1') CALL TEXT ('ivarb8z = (ivar-1)/3+1') IF (.NOT.PARA) THEN CALL TEXT ('ISET1 = 1') CALL TEXT ('ISET2 = NSAVE') CALL TEXT ('ISINC = 1') ELSE CALL MESS (0,123) CALL TEXT ('ISET1 = 0') CALL TEXT ('ISET2 = NSAVE') CALL TEXT ('ISINC = 1') CALL INVAR ('ISET1',.FALSE.) CALL INVAR ('ISET2',.FALSE.) CALL INVAR ('ISINC',.FALSE.) ENDIF CALL MESS (0,59) CALL TEXT ('TITLE = '' '' ') CALL INSTR ('TITLE',.FALSE.) CALL STATE (ISTAT) IF (DP) THEN CALL TEXT('call dtdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,590) ISTAT CALL TEXT ('call dtdpr(xout8z,yout8z,uout(0,0,ivara8z,'// & 'ivarb8z,is8z),npts8z,inrg8z,title,tout8z(is8z))') ELSE CALL TEXT('call tdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,590) ISTAT CALL TEXT ('call tdpr(xout8z,yout8z,uout(0,0,ivara8z,'// & 'ivarb8z,is8z),npts8z,inrg8z,title,tout8z(is8z))') ENDIF WRITE (LUN,610) ISTAT ELSE IF (IPLOT .EQ. 2) THEN C SURFACE PLOT DONE CALL COM (2, ' *******SURFACE PLOT') CALL MESS (0,256 + IND) CALL IREAD ('IVAR', IVAR, 1, 3*NEQN) CALL TEXT ('ivara8z = mod(ivar-1,3)+1') CALL TEXT ('ivarb8z = (ivar-1)/3+1') IF (.NOT.PARA) THEN CALL TEXT ('ISET1 = 1') CALL TEXT ('ISET2 = NSAVE') CALL TEXT ('ISINC = 1') ELSE CALL MESS (0,123) CALL TEXT ('ISET1 = 0') CALL TEXT ('ISET2 = NSAVE') CALL TEXT ('ISINC = 1') CALL INVAR ('ISET1',.FALSE.) CALL INVAR ('ISET2',.FALSE.) CALL INVAR ('ISINC',.FALSE.) ENDIF CALL MESS (0,127) CALL TEXT ('VLON = 45.0') CALL TEXT ('VLAT = 45.0') CALL INVAR ('VLAT', .FALSE.) CALL INVAR ('VLON', .FALSE.) CALL COM (2,' ') CALL TEXT ('alow = amin8z(ivar)') CALL TEXT ('ahigh = amax8z(ivar)') CALL MESS (0,126) CALL TEXT ('UMIN = 0.0') CALL TEXT ('UMAX = 0.0') CALL INVAR ('UMIN', .FALSE.) CALL INVAR ('UMAX', .FALSE.) CALL MESS (0,59) CALL TEXT ('TITLE = '' '' ') CALL INSTR ('TITLE',.FALSE.) CALL STATE (ISTAT) IF (DP) THEN CALL TEXT('call dtdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,590) ISTAT CALL TEXT ('call dtdpld(xout8z,yout8z,uout(0,0,'// & 'ivara8z,ivarb8z,is8z),nx,ny,inrg8z,title,vlon,vlat,'// & 'umin,umax,tout8z(is8z))') ELSE CALL TEXT('call tdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,590) ISTAT CALL TEXT ('call tdpld(xout8z,yout8z,uout(0,0,'// & 'ivara8z,ivarb8z,is8z),nx,ny,inrg8z,title,vlon,vlat,'// & 'umin,umax,tout8z(is8z))') ENDIF WRITE (LUN,610) ISTAT ELSE IF (IPLOT .EQ. 3) THEN C CONTOUR PLOT DONE CALL COM (2, ' *******CONTOUR PLOT') CALL MESS (0,256 + IND) CALL IREAD ('IVAR', IVAR, 1, 3*NEQN) CALL TEXT ('ivara8z = mod(ivar-1,3)+1') CALL TEXT ('ivarb8z = (ivar-1)/3+1') IF (.NOT.PARA) THEN CALL TEXT ('ISET1 = 1') CALL TEXT ('ISET2 = NSAVE') CALL TEXT ('ISINC = 1') ELSE CALL MESS (0,123) CALL TEXT ('ISET1 = 0') CALL TEXT ('ISET2 = NSAVE') CALL TEXT ('ISINC = 1') CALL INVAR ('ISET1',.FALSE.) CALL INVAR ('ISET2',.FALSE.) CALL INVAR ('ISINC',.FALSE.) ENDIF CALL MESS (0,260) CALL IFYES (YES) IF (YES) THEN CALL TEXT ('NODIST = .TRUE.') ELSE CALL TEXT ('NODIST = .FALSE.') ENDIF CALL COM (2,' ') CALL TEXT ('alow = amin8z(ivar)') CALL TEXT ('ahigh = amax8z(ivar)') CALL MESS (0,261) CALL TEXT ('UMIN = 0.0') CALL TEXT ('UMAX = 0.0') CALL INVAR ('UMIN', .FALSE.) CALL INVAR ('UMAX', .FALSE.) CALL MESS (0,262) CALL IFYES (YES) IF (YES) THEN CALL TEXT ('FILLIN = .TRUE.') ELSE CALL TEXT ('FILLIN = .FALSE.') ENDIF CALL MESS (0,59) CALL TEXT ('TITLE = '' '' ') CALL INSTR ('TITLE',.FALSE.) CALL STATE (ISTAT) IF (DP) THEN CALL TEXT('call dtdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,590) ISTAT CALL TEXT ('call dtdplg(uout(0,0,ivara8z,ivarb8z,is8z)'// & ',nx,ny,xa,ya,hx8z,hy8z,inrg8z,xbd8z,ybd8z,nbd8z,'// & 'title,umin,umax,nodist,fillin,tout8z(is8z))') ELSE CALL TEXT('call tdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,590) ISTAT CALL TEXT ('call tdplg(uout(0,0,ivara8z,ivarb8z,is8z)'// & ',nx,ny,xa,ya,hx8z,hy8z,inrg8z,xbd8z,ybd8z,nbd8z,'// & 'title,umin,umax,nodist,fillin,tout8z(is8z))') ENDIF WRITE (LUN,610) ISTAT ELSE IF (IPLOT .EQ. 4) THEN C VECTOR FIELD PLOT DONE CALL COM (2, ' *******VECTOR FIELD PLOT') CALL MESS (0,263 + IND) CALL IREAD ('IVARX', IVARX, 1, 3*NEQN) CALL IREAD ('IVARY', IVARY, 1, 3*NEQN) CALL TEXT ('ivarxa8z = mod(ivarx-1,3)+1') CALL TEXT ('ivarxb8z = (ivarx-1)/3+1') CALL TEXT ('ivarya8z = mod(ivary-1,3)+1') CALL TEXT ('ivaryb8z = (ivary-1)/3+1') IF (.NOT.PARA) THEN CALL TEXT ('ISET1 = 1') CALL TEXT ('ISET2 = NSAVE') CALL TEXT ('ISINC = 1') ELSE CALL MESS (0,123) CALL TEXT ('ISET1 = 0') CALL TEXT ('ISET2 = NSAVE') CALL TEXT ('ISINC = 1') CALL INVAR ('ISET1',.FALSE.) CALL INVAR ('ISET2',.FALSE.) CALL INVAR ('ISINC',.FALSE.) ENDIF CALL MESS (0,260) CALL IFYES (YES) IF (YES) THEN CALL TEXT ('NODIST = .TRUE.') ELSE CALL TEXT ('NODIST = .FALSE.') ENDIF CALL COM (2,' ') CALL TEXT & ('a1mag = max(abs(amin8z(ivarx)),abs(amax8z(ivarx)))') CALL TEXT & ('a2mag = max(abs(amin8z(ivary)),abs(amax8z(ivary)))') CALL MESS (0,267) CALL TEXT ('VR1MAG = 0.0') CALL TEXT ('VR2MAG = 0.0') CALL INVAR ('VR1MAG', .FALSE.) CALL INVAR ('VR2MAG', .FALSE.) CALL MESS (0,59) CALL TEXT ('TITLE = '' '' ') CALL INSTR ('TITLE',.FALSE.) CALL STATE (ISTAT) IF (DP) THEN CALL TEXT('call dtdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,590) ISTAT CALL TEXT ('call dtdpla('// & 'uout(0,0,ivarxa8z,ivarxb8z,is8z),'// & 'uout(0,0,ivarya8z,ivaryb8z,is8z),nx,ny,xa,ya,hx8z,'// & 'hy8z,inrg8z,xbd8z,ybd8z,nbd8z,title,vr1mag,vr2mag,'// & 'nodist,tout8z(is8z))') ELSE CALL TEXT('call tdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,590) ISTAT CALL TEXT ('call tdpla('// & 'uout(0,0,ivarxa8z,ivarxb8z,is8z),'// & 'uout(0,0,ivarya8z,ivaryb8z,is8z),nx,ny,xa,ya,hx8z,'// & 'hy8z,inrg8z,xbd8z,ybd8z,nbd8z,title,vr1mag,vr2mag,'// & 'nodist,tout8z(is8z))') ENDIF WRITE (LUN,610) ISTAT ELSE IF (IPLOT .EQ. 5) THEN C CROSS-SECTION PLOTS CALL COM (2, ' *******1D CROSS-SECTION PLOTS') CALL MESS (0,256 + IND) CALL IREAD ('IVAR', IVAR, 1, 3*NEQN) CALL MESS (1,268) ICSLIM = 3 IF (.NOT.PARA) ICSLIM = 2 CALL IREAD (' ', ICS, 1, ICSLIM) IF (ICS.EQ.1) THEN CALL COM (2, ' X IS VARIABLE') CALL TEXT ('ics8z = 1') CALL MESS (0,269) CALL IREAD ('NYVALS', NYVALS, 1, 100) CALL INVEC ('YCROSS', 1, NYVALS, .TRUE.) ELSE IF (ICS.EQ.2) THEN CALL COM (2, ' Y IS VARIABLE') CALL TEXT ('ics8z = 2') CALL MESS (0,270) CALL IREAD ('NXVALS', NXVALS, 1, 100) CALL INVEC ('XCROSS', 1, NXVALS, .TRUE.) ELSE IF (ICS.EQ.3) THEN CALL COM (2, ' T IS VARIABLE') CALL TEXT ('ics8z = 3') CALL MESS (0,271) CALL IREAD ('NXVALS', NXVALS, 1, 100) CALL INVEC ('XCROSS', 1, NXVALS, .TRUE.) CALL IREAD ('NYVALS', NYVALS, 1, 100) CALL INVEC ('YCROSS', 1, NYVALS, .TRUE.) ENDIF IF (ICS.LE.2) THEN IF (.NOT.PARA) THEN CALL TEXT ('ISET1 = 1') CALL TEXT ('ISET2 = NSAVE') CALL TEXT ('ISINC = 1') ELSE CALL MESS (0,123) CALL TEXT ('ISET1 = 0') CALL TEXT ('ISET2 = NSAVE') CALL TEXT ('ISINC = 1') CALL INVAR ('ISET1',.FALSE.) CALL INVAR ('ISET2',.FALSE.) CALL INVAR ('ISINC',.FALSE.) ENDIF ENDIF CALL COM (2,' ') CALL TEXT ('alow = amin8z(ivar)') CALL TEXT ('ahigh = amax8z(ivar)') CALL MESS (0,126) CALL TEXT ('UMIN = 0.0') CALL TEXT ('UMAX = 0.0') CALL INVAR ('UMIN', .FALSE.) CALL INVAR ('UMAX', .FALSE.) CALL MESS (0,59) CALL TEXT ('TITLE = '' '' ') CALL INSTR ('TITLE',.FALSE.) CALL STATE (ISTAT) CALL STATE (ISTAT2) IF (DP) THEN IF (ICS.EQ.1) THEN CALL TEXT('call dtdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,590) ISTAT2 WRITE (LUN,430) ISTAT CALL TEXT ('call dtdpzx(ycross(jyv8z),ya,yb,ny,jy8z)') ELSE IF (ICS.EQ.2) THEN CALL TEXT('call dtdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,590) ISTAT2 WRITE (LUN,420) ISTAT CALL TEXT ('call dtdpzx(xcross(ixv8z),xa,xb,nx,ix8z)') ELSE IF (ICS.EQ.3) THEN CALL TEXT ('is8z = 0') WRITE (LUN,420) ISTAT2 WRITE (LUN,430) ISTAT CALL TEXT ('call dtdpzx(xcross(ixv8z),xa,xb,nx,ix8z)') CALL TEXT ('call dtdpzx(ycross(jyv8z),ya,yb,ny,jy8z)') ENDIF CALL TEXT ('call dtdplp(ics8z,ivar,tout8z,nsave,'// & 'xout8z,yout8z,inrg8z,nx,ny,uout,neqn,title,'// & 'umin,umax,ix8z,jy8z,is8z)') ELSE IF (ICS.EQ.1) THEN CALL TEXT('call tdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,590) ISTAT2 WRITE (LUN,430) ISTAT CALL TEXT ('call tdpzx(ycross(jyv8z),ya,yb,ny,jy8z)') ELSE IF (ICS.EQ.2) THEN CALL TEXT('call tdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,590) ISTAT2 WRITE (LUN,420) ISTAT CALL TEXT ('call tdpzx(xcross(ixv8z),xa,xb,nx,ix8z)') ELSE IF (ICS.EQ.3) THEN CALL TEXT ('is8z = 0') WRITE (LUN,420) ISTAT2 420 FORMAT (6X,'do ',I5,' ixv8z=1,nxvals') WRITE (LUN,430) ISTAT 430 FORMAT (6X,'do ',I5,' jyv8z=1,nyvals') CALL TEXT ('call tdpzx(xcross(ixv8z),xa,xb,nx,ix8z)') CALL TEXT ('call tdpzx(ycross(jyv8z),ya,yb,ny,jy8z)') ENDIF CALL TEXT ('call tdplp(ics8z,ivar,tout8z,nsave,'// & 'xout8z,yout8z,inrg8z,nx,ny,uout,neqn,title,'// & 'umin,umax,ix8z,jy8z,is8z)') ENDIF WRITE (LUN,610) ISTAT WRITE (LUN,610) ISTAT2 ELSE IF (IPLOT .EQ. 6) THEN C STRESS FIELD PLOT DONE CALL COM (2, ' *******STRESS FIELD PLOT') CALL MESS (0,272 + IND - 1) CALL IREAD ('IVAR11', IVAR11, 1, 3*NEQN) CALL IREAD ('IVAR22', IVAR22, 1, 3*NEQN) CALL IREAD ('IVAR12', IVAR12, 1, 3*NEQN) CALL TEXT ('ivar11a8z = mod(ivar11-1,3)+1') CALL TEXT ('ivar11b8z = (ivar11-1)/3+1') CALL TEXT ('ivar22a8z = mod(ivar22-1,3)+1') CALL TEXT ('ivar22b8z = (ivar22-1)/3+1') CALL TEXT ('ivar12a8z = mod(ivar12-1,3)+1') CALL TEXT ('ivar12b8z = (ivar12-1)/3+1') IF (.NOT.PARA) THEN CALL TEXT ('ISET1 = 1') CALL TEXT ('ISET2 = NSAVE') CALL TEXT ('ISINC = 1') ELSE CALL MESS (0,123) CALL TEXT ('ISET1 = 0') CALL TEXT ('ISET2 = NSAVE') CALL TEXT ('ISINC = 1') CALL INVAR ('ISET1',.FALSE.) CALL INVAR ('ISET2',.FALSE.) CALL INVAR ('ISINC',.FALSE.) ENDIF CALL MESS (0,260) CALL IFYES (YES) IF (YES) THEN CALL TEXT ('NODIST = .TRUE.') ELSE CALL TEXT ('NODIST = .FALSE.') ENDIF CALL COM (2,' ') CALL TEXT & ('a11m8z = max(abs(amin8z(ivar11)),abs(amax8z(ivar11)))') CALL TEXT & ('a22m8z = max(abs(amin8z(ivar22)),abs(amax8z(ivar22)))') CALL TEXT & ('a12m8z = max(abs(amin8z(ivar12)),abs(amax8z(ivar12)))') CALL TEXT ('astrmx = max(a11m8z,a22m8z)+a12m8z') CALL MESS (0,275) CALL TEXT ('STRMAX = 0.0') CALL INVAR ('STRMAX', .FALSE.) CALL MESS (0,59) CALL TEXT ('TITLE = '' '' ') CALL INSTR ('TITLE',.FALSE.) CALL STATE (ISTAT) IF (DP) THEN CALL TEXT('call dtdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,590) ISTAT CALL TEXT('call dtdplb('// & 'uout(0,0,ivar11a8z,ivar11b8z,is8z),'// & 'uout(0,0,ivar22a8z,ivar22b8z,is8z),'// & 'uout(0,0,ivar12a8z,ivar12b8z,is8z),'// & 'nx,ny,xa,ya,hx8z,hy8z,inrg8z,xbd8z,ybd8z,nbd8z,'// & 'title,nodist,strmax,tout8z(is8z))') ELSE CALL TEXT('call tdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,590) ISTAT CALL TEXT('call tdplb('// & 'uout(0,0,ivar11a8z,ivar11b8z,is8z),'// & 'uout(0,0,ivar22a8z,ivar22b8z,is8z),'// & 'uout(0,0,ivar12a8z,ivar12b8z,is8z),'// & 'nx,ny,xa,ya,hx8z,hy8z,inrg8z,xbd8z,ybd8z,nbd8z,'// & 'title,nodist,strmax,tout8z(is8z))') ENDIF WRITE (LUN,610) ISTAT ENDIF GO TO 410 440 CONTINUE C ADD DUMMY PDE2D FUNCTIONS LUN = LFUNS CALL COM (2,' dummy routines') CALL TEXT ('function axis8z(i8z,x,y,z,ical8z)') CALL PREC CALL TEXT ('axis8z = 0') CALL TEXT ('return') CALL TEXT ('end') C WRITE POSTPR CALL TEXT (' ') CALL TEXT (' ') CALL TEXT ( & 'subroutine postpr(tout,nsave,xout,yout,inrg,nx,ny,uout,neqn)') CALL PREC CALL TEXT & ('dimension xout(0:nx,0:ny),yout(0:nx,0:ny),tout(0:nsave)') CALL TEXT & ('dimension inrg(0:nx,0:ny),uout(0:nx,0:ny,3,neqn,0:nsave)') WRITE (LUN,535) (PARNM(I),I=1,NPARN) IF (DP) THEN CALL TEXT ('common /dtdp27/ itask,npes,icomm') CALL TEXT ('common /dtdp46/ eps8z,cgtl8z,npmx8z,itype,near8z') ELSE CALL TEXT ('common / tdp27/ itask,npes,icomm') CALL TEXT ('common / tdp46/ eps8z,cgtl8z,npmx8z,itype,near8z') ENDIF CALL TEXT ('data lun,lud/0,47/') CALL TEXT ('if (itask.gt.0) return') CALL COM (2,'UOUT(I,J,IDER,IEQ,L) = U_IEQ, if IDER=1') CALL COM (2,' A_IEQ, if IDER=2') CALL COM (2,' B_IEQ, if IDER=3') CALL COM (2,' (possibly as modified by UPRINT,..)') CALL COM (2,' at the point (XOUT(I,J) , YOUT(I,J))') CALL COM (2,' at time/iteration TOUT(L).') CALL COM (2,'INRG(I,J) = 1 if this point is in R') CALL COM (2,' = 0 otherwise') CALL COM (2,' ******* ADD POSTPROCESSING CODE HERE:') CALL COM (2,' IN THE EXAMPLE BELOW, MATLAB PLOTFILES pde2d.m,') CALL COM (2,' pde2d.rdm CREATED (REMOVE C! COMMENTS TO ACTIVATE)') CALL COM (3,' if (lun.eq.0) then') CALL COM (3,' lun = 46') CALL COM (3,' open (lun,file=''pde2d.m'')') CALL COM (3,' open (lud,file=''pde2d.rdm'')') CALL COM (3, & ' write (lun,*) ''fid = fopen(''''pde2d.rdm'''');''') CALL COM (3,' endif') CALL COM (3,' do 78753 l=0,nsave') IF (DP) THEN CALL COM (3,' if (tout(l).ne.dtdplx(2)) nsave0 = l') ELSE CALL COM (3,' if (tout(l).ne. tdplx(2)) nsave0 = l') ENDIF CALL COM (4,'78753 continue') CALL COM (3,' write (lud,78754) nsave0') CALL COM (3,' write (lud,78754) neqn') CALL COM (3,' write (lud,78754) nx') CALL COM (3,' write (lud,78754) ny') CALL COM (4,'78754 format (i8)') CALL COM (3,' do 78756 i=0,nx') CALL COM (3,' do 78755 j=0,ny') CALL COM (3,' write (lud,78762) xout(i,j),yout(i,j)') CALL COM (4,'78755 continue') CALL COM (4,'78756 continue') CALL COM (3,' do 78761 l=0,nsave0') CALL COM (3,' write (lud,78762) tout(l)') CALL COM (3,' do 78760 ieq=1,neqn') CALL COM (3,' do 78759 ider=1,3') CALL COM (3,' do 78758 i=0,nx') CALL COM (3,' do 78757 j=0,ny') CALL COM (3,' if (inrg(i,j).eq.1) then') CALL COM (3,' write (lud,78762) uout(i,j,ider,ieq,l)') CALL COM (3,' else') CALL COM (3,' write (lud,78763)') CALL COM (3,' endif') CALL COM (4,'78757 continue') CALL COM (4,'78758 continue') CALL COM (4,'78759 continue') CALL COM (4,'78760 continue') CALL COM (4,'78761 continue') CALL COM (4,'78762 format (e16.8)') CALL COM (4,'78763 format (''NaN'')') CALL COM (2,' ******* WRITE pde2d.m ') CALL COM (3,' call mtdp2dg(itype,lun)') CALL TEXT ('return') CALL TEXT ('end') C ENTER USER-SUPPLIED FUNCTIONS CALL MESS (1,61) CALL IFYES (YES) IF (YES) CALL IADD (0, ' ') C CALL TDPT/DTDPT TO INTERPOLATE TABULAR OUTPUT CALL MESS (1,128) CALL IFYES (YES) IF (YES) THEN C 450 CONTINUE CALL MESS (1,276) 460 CONTINUE WRITE (INTOUT,470) 470 FORMAT (' Function name =') CALL READLN (INPT, 6, NOMORE) IF (NOMORE) THEN WRITE (INTOUT,490) GO TO 460 ENDIF DO 480 I = 1,40 IF (INPT(1) .EQ. LET2(I)) GO TO 500 480 CONTINUE WRITE (INTOUT,490) 490 FORMAT ('|---- Illegal function name, re-enter in columns 1-6') GO TO 460 500 CONTINUE WRITE (LUN,510) INPT 510 FORMAT (//,6X,'function ',6A1,'(x,y)') CALL PREC CALL MESS (0,277) CALL INPARM ('NWORK', NWORK, 10, INF) CALL TEXT ('dimension work(nwork)') CALL TEXT ('character*40 fname') IF (DP) THEN CALL TEXT ('data work(1) /0.0d0/') ELSE CALL TEXT ('data work(1) /0.0/') ENDIF CALL MESS (0,278) CALL INSTR ('FNAME', .TRUE.) CALL MESS (0,132) CALL TEXT ('ISET = 1') CALL INVAR ('ISET', .FALSE.) CALL MESS (0,133) CALL IREAD ('KDEG', KDEG, 1, 3) IF (DP) THEN WRITE (LUN,520) INPT 520 FORMAT (6X,6A1,' = dtdpt(fname,iset,work,nwork,kdeg,x,y)') ELSE WRITE (LUN,530) INPT 530 FORMAT (6X,6A1,' = tdpt(fname,iset,work,nwork,kdeg,x,y)') ENDIF CALL TEXT ('return') CALL TEXT ('end') CALL MESS (1,134) CALL IFYES (YES) IF (YES) GO TO 450 C ENDIF CALL MESS (1,411) LUN = LFORT WRITE (LUN,610) IST999 CALL TEXT ('call endgks') CALL TEXT ('stop') CALL TEXT ('end') LUN = LPARAM WRITE (LUN,535) (PARNM(I),I=1,NPARN) 535 FORMAT (6X,'common/parm8z/ pi',6A7,/,(5X,'&',9A7)) C CONCATENATE PARAMETERS FILE, MAIN PROGRAM, AND SUBPROGRAMS REWIND LFORT 540 CONTINUE READ (LFORT,550,END=560) LINE 550 FORMAT (A79) WRITE (LPARAM,550) LINE GO TO 540 560 CONTINUE REWIND LFUNS 570 CONTINUE READ (LFUNS,550,END=580) LINE WRITE (LPARAM,550) LINE GO TO 570 580 CONTINUE 590 FORMAT (6X,'do ',I5,' is8z=iset1,iset2,isinc') 610 FORMAT (I5,' continue') STOP END SUBROUTINE PDE2DC PARAMETER (NEQNMX=99) LOGICAL YES,PARA,ELL,EIGEN,LINEAR,NOMORE,EVCMPX,DP, & RESTRT,FDIFF,UNCOM COMMON /EXMP/ LEVEL,IEXMP,DP COMMON /LUNITS/ INTIN,INTOUT,LMESS,LUN,LPARAM,LFORT,LFUNS,INFIL & ,IECHO COMMON /UNKNWN/ NUNK(NEQNMX),UNK(NEQNMX) COMMON /PARMS/ LSCREN,ISMX2D,ISMX3D,UNCOM C CHARACTER VARIABLES CHARACTER*79 LINE CHARACTER*8 CNUM8 CHARACTER*7 PARNM(176) CHARACTER*6 CNUM6 CHARACTER*3 UNK,FORB(26) CHARACTER*1 INPT(6),LET1(46),LET2(52) DATA LET1 / & 'A','B','C','D','E','F','G','H','O','Q','R','S','U','V','W','Z', & 'a','b','c','d','e','f','g','h','o','q','r','s','u','v','w','z', & 'I','J','K','L','M','N','P','i','j','k','l','m','n','p'/ DATA LET2 / 'A','B','C','D','E','F','G','H','O','P', & 'Q','R','S','T','U','V','W','X','Y','Z', & 'a','b','c','d','e','f','g','h','o','p', & 'q','r','s','t','u','v','w','x','y','z', & 'I','J','K','L','M','N','i','j','k','l','m','n'/ DATA FORB/ &'P1 ','p1 ','P2 ','p2 ','PI ','Pi ','pI ','pi ', &'DT ','TF ','Dt ','Tf ','dT ','tF ','dt ','tf ','T0 ','t0 ', &'X1 ','x1 ','X2 ','x2 ','Y1 ','y1 ','Y2 ','y2 '/ C INF = 10000 CALL COM (2, & '*** 2D PROBLEM SOLVED (COLLOCATION METHOD) ***') CALL MESS (0,7) CALL IFYES (DP) CALL PREC WRITE (LUN,90) NEQNMX LUN = LFORT CALL TEXT ('dimension p1grid(np1grid),p2grid(np2grid),'// & 'p3grid(np3grid),p1out8z(0:np1,0:np2),p2out8z(0:np1,0:np2),'// & 'p3out8z(0:np1,0:np2),p1cross(100),p2cross(100),'// & 'tout8z(0:nsave)') CALL COM (2, & ' dimension xres8z(nxp8z),yres8z(nyp8z),zres8z(nzp8z),') CALL COM (2,'& ures8z(neqn,nxp8z,nyp8z,nzp8z)') CALL TEXT ('allocatable iwrk8z(:),rwrk8z(:)') CALL COM (2,' dimension iwrk8z(iiwk8z),rwrk8z(irwk8z)') CALL TEXT ('character*40 title') CALL TEXT ('logical linear,crankn,noupdt,nodist,fillin,'// & 'evcmpx,adapt,plot,lsqfit,fdiff,solid,econ8z,ncon8z,restrt,'// & 'gridid') IF (DP) THEN CALL TEXT & ('common/dtdp14/ sint8z(20),bint8z(20),slim8z(20),blim8z(20)') CALL TEXT ('common/dtdp15/ evlr8z,ev0r,evli8z,ev0i,evcmpx') CALL TEXT ('common/dtdp16/ p8z,evr8z(50),evi8z(50)') CALL TEXT ('common/dtdp19/ toler(neqnmx),adapt') CALL TEXT ('common/dtdp30/ econ8z,ncon8z') CALL TEXT ('common/dtdp45/ perdc(neqnmx)') CALL TEXT ('common/dtdp46/ eps8z,cgtl8z,npmx8z,itype,near8z') CALL TEXT ('common/dtdp52/ nxa8z,nya8z,nza8z,kd8z') CALL TEXT ('common/dtdp53/ work8z(nxp8z*nyp8z*nzp8z+9)') CALL TEXT ('common/dtdp64/ amin8z(4*neqnmx),amax8z(4*neqnmx)') CALL TEXT ('common/dtdp76/ mdim8z,nx18z,ny18z,p1a,p1b,p2a,'// & 'p2b,uout(0:np1,0:np2,4,neqn,0:nsave)') ELSE CALL TEXT & ('common/ tdp14/ sint8z(20),bint8z(20),slim8z(20),blim8z(20)') CALL TEXT ('common/ tdp15/ evlr8z,ev0r,evli8z,ev0i,evcmpx') CALL TEXT ('common/ tdp16/ p8z,evr8z(50),evi8z(50)') CALL TEXT ('common/ tdp19/ toler(neqnmx),adapt') CALL TEXT ('common/ tdp30/ econ8z,ncon8z') CALL TEXT ('common/ tdp45/ perdc(neqnmx)') CALL TEXT ('common/ tdp46/ eps8z,cgtl8z,npmx8z,itype,near8z') CALL TEXT ('common/ tdp52/ nxa8z,nya8z,nza8z,kd8z') CALL TEXT ('common/ tdp53/ work8z(nxp8z*nyp8z*nzp8z+9)') CALL TEXT ('common/ tdp64/ amin8z(4*neqnmx),amax8z(4*neqnmx)') CALL TEXT ('common/ tdp76/ mdim8z,nx18z,ny18z,p1a,p1b,p2a,'// & 'p2b,uout(0:np1,0:np2,4,neqn,0:nsave)') ENDIF CALL TEXT ('pi = 4.0*atan(1.d0)') CALL TEXT ('zr8z = 0.0') CALL TEXT ('nxa8z = nxp8z') CALL TEXT ('nya8z = nyp8z') CALL TEXT ('nza8z = nzp8z') CALL TEXT ('nx18z = np1+1') CALL TEXT ('ny18z = np2+1') CALL TEXT ('mdim8z = 4') CALL TEXT ('kd8z = kdeg8z') CALL MESS (0,8) CALL TEXT ('NPROB = 1') CALL INVAR ('NPROB',.FALSE.) CALL STATE (IST999) WRITE (LUN,10) IST999 10 FORMAT (6X,'do ',I5,' iprob=1,nprob') CALL MESS (0,279) CALL GUI() CALL GLOBP(LET1,46,LET2,52,FORB,26,PARNM,NPARN) CALL MESS (1,10) CALL IFYES (YES) LEVEL = 2 IF (YES) LEVEL = 3 LUN = LFUNS CALL TEXT (' ') CALL TEXT (' ') CALL TEXT ('subroutine tran8z(itrans,p1,p2,p38z)') CALL PREC IF (DP) THEN CALL TEXT ('common /dtdp41/x,y,z8z,x1,x2,x38z,y1,y2,y38z'// & ',z18z,z28z,z38z,x11,x21,x31,x12,x22,x32,x13,x23,x33'// & ',y11,y21,y31,y12,y22,y32,y13,y23,y33'// & ',z11,z21,z31,z12,z22,z32,z13,z23,z33') ELSE CALL TEXT ('common / tdp41/x,y,z8z,x1,x2,x38z,y1,y2,y38z'// & ',z18z,z28z,z38z,x11,x21,x31,x12,x22,x32,x13,x23,x33'// & ',y11,y21,y31,y12,y22,y32,y13,y23,y33'// & ',z11,z21,z31,z12,z22,z32,z13,z23,z33') ENDIF WRITE (LUN,555) (PARNM(I),I=1,NPARN) CALL MESS (0,280) 19 CALL IREAD ('ITRANS', ITRANS, -3, 3) IF (IABS(ITRANS).EQ.2) THEN WRITE (INTOUT,20) 20 FORMAT ('|---- Illegal input') GO TO 19 ENDIF IF (ITRANS.EQ.3) THEN CALL IADD(3,'X,Y,X1,...') CALL INVAR('X',.TRUE.) CALL INVAR('Y',.TRUE.) CALL SPACER CALL INVAR('X1',.TRUE.) CALL INVAR('X2',.TRUE.) CALL SPACER CALL INVAR('Y1',.TRUE.) CALL INVAR('Y2',.TRUE.) CALL SPACER CALL INVAR('X11',.TRUE.) CALL INVAR('X12',.TRUE.) CALL INVAR('X22',.TRUE.) CALL SPACER CALL INVAR('Y11',.TRUE.) CALL INVAR('Y12',.TRUE.) CALL INVAR('Y22',.TRUE.) ELSE IF (ITRANS.EQ.-3) THEN CALL IADD(3,'X,Y') CALL GUI() CALL INVAR('X',.TRUE.) CALL GUI() CALL INVAR('Y',.TRUE.) ENDIF CALL COM (2,' ') CALL TEXT ('z8z = p38z') CALL TEXT ('z38z = 1') CALL TEXT ('return') CALL TEXT ('end') C RECTANGULAR GRID LUN = LFORT CALL MESS (0,281) IF (DP) THEN CALL TEXT ('call dtdpwx(p1grid,np1grid,0)') CALL TEXT ('call dtdpwx(p2grid,np2grid,0)') ELSE CALL TEXT ('call tdpwx(p1grid,np1grid,0)') CALL TEXT ('call tdpwx(p2grid,np2grid,0)') ENDIF C LUN = LPARAM CALL COM (1,'NP1GRID = number of P1-grid lines') CALL GUI() CALL INPARM ('NP1GRID',NP1GRID,1,INF) LUN = LFORT CALL COM (2,' P1GRID DEFINED') CALL GUI() CALL INVAR ('P1GRID(1)',.TRUE.) CALL INVEC ('P1GRID',2,NP1GRID - 1,.FALSE.) CALL GUI() IF (NP1GRID.GT.1) CALL INVAR ('P1GRID(NP1GRID)',.TRUE.) C LUN = LPARAM CALL COM (1,'NP2GRID = number of P2-grid lines') CALL GUI() CALL INPARM ('NP2GRID',NP2GRID,1,INF) LUN = LFORT CALL COM (2,' P2GRID DEFINED') CALL GUI() CALL INVAR ('P2GRID(1)',.TRUE.) CALL INVEC ('P2GRID',2,NP2GRID - 1,.FALSE.) CALL GUI() IF (NP2GRID.GT.1) CALL INVAR ('P2GRID(NP2GRID)',.TRUE.) C CALL COM (2,' ') CALL TEXT ('p3grid(1) = 0') IF (DP) THEN CALL TEXT ('call dtdpwx(p1grid,np1grid,1)') CALL TEXT ('call dtdpwx(p2grid,np2grid,1)') ELSE CALL TEXT ('call tdpwx(p1grid,np1grid,1)') CALL TEXT ('call tdpwx(p2grid,np2grid,1)') ENDIF C LUN = LFORT CALL MESS (0,282) CALL IREAD ('ISOLVE', ISOLVE, 1, ISMX3D) C IDENTIFY TYPE OF PDE CALL MESS (1,11) CALL IREAD (' ',ITYPE,1,3) ELL = ITYPE .EQ. 1 PARA = ITYPE .EQ. 2 EIGEN = ITYPE .EQ. 3 IF (EIGEN) THEN C EIGENVALUE PROBLEM SOLVED CALL COM (2, ' *******EIGENVALUE PROBLEM') CALL MESS (0,12) CALL PAWS CALL TEXT ('ITYPE = 3') CALL COM (2,' ') CALL COM (2,' P8Z = 0.0') LINEAR = .TRUE. CALL TEXT ('linear = .true.') CALL TEXT ('t0 = 0.0') CALL TEXT ('dt = 1.0') CALL TEXT ('crankn = .false.') CALL TEXT ('noupdt = .true.') CALL MESS (0,13) CALL IFYES (EVCMPX) IF (.NOT.EVCMPX) THEN CALL TEXT ('EVCMPX = .FALSE.') CALL MESS (0,14) CALL TEXT ('EV0R = 0.0') CALL GUI() CALL INVAR ('EV0R', .FALSE.) ELSE CALL TEXT ('EVCMPX = .TRUE.') CALL MESS (0,15) CALL TEXT ('EV0R = 0.0') CALL TEXT ('EV0I = 0.0') CALL INVAR ('EV0R', .FALSE.) CALL INVAR ('EV0I', .FALSE.) ENDIF CALL MESS (0,16) CALL TEXT ('NSTEPS = 25') CALL INVAR ('NSTEPS',.FALSE.) ELSE IF (PARA) THEN C TIME DEPENDENT PROBLEM SOLVED CALL COM (2,' *******TIME-DEPENDENT PROBLEM') CALL TEXT ('itype = 2') CALL MESS (0,17) CALL TEXT ('T0 = 0.0') CALL GUI() CALL INVAR ('T0',.FALSE.) CALL GUI() CALL INVAR ('TF',.TRUE.) CALL MESS (0,18) CALL IFYES (LINEAR) IF (LINEAR) THEN CALL TEXT ('LINEAR = .TRUE.') ELSE CALL TEXT ('LINEAR = .FALSE.') ENDIF CALL MESS (0,19) CALL IFYES (YES) CALL GUI() IF (YES) THEN CALL TEXT ('ADAPT = .TRUE.') CALL TEXT ('TOLER(1) = 0.01') CALL INVAR ('TOLER(1)', .FALSE.) IF (LINEAR) CALL MESS (2,20) CALL TEXT ('NOUPDT = .FALSE.') CALL MESS (0,21) ELSE CALL TEXT ('ADAPT = .FALSE.') CALL TEXT ('TOLER(1) = 0.01') IF (LINEAR) THEN CALL MESS (0,20) CALL IFYES (YES) CALL GUI() IF (YES) THEN CALL TEXT ('NOUPDT = .TRUE.') ELSE CALL TEXT ('NOUPDT = .FALSE.') ENDIF ELSE CALL TEXT ('NOUPDT = .FALSE.') ENDIF CALL MESS (0,22) ENDIF CALL GUI() CALL INVAR ('NSTEPS',.TRUE.) CALL TEXT ('dt = (tf-t0)/max(nsteps,1)') CALL MESS (0,65) CALL IFYES (YES) IF (YES) THEN CALL TEXT ('CRANKN = .TRUE.') ELSE CALL TEXT ('CRANKN = .FALSE.') ENDIF ELSE C STEADY STATE PROBLEM SOLVED CALL COM (2,' *******STEADY-STATE PROBLEM') CALL TEXT ('itype = 1') CALL TEXT ('t0 = 0.0') CALL TEXT ('dt = 1.0') CALL TEXT ('crankn = .false.') CALL TEXT ('noupdt = .false.') CALL MESS (0,18) CALL IFYES (LINEAR) IF (LINEAR) THEN CALL TEXT ('LINEAR = .TRUE.') CALL COM (2, ' Number of Newton iterations') CALL TEXT ('NSTEPS = 1') ELSE CALL TEXT ('LINEAR = .FALSE.') CALL MESS (0,24) CALL TEXT ('NSTEPS = 15') CALL INVAR ('NSTEPS',.FALSE.) ENDIF ENDIF LUN = LPARAM CALL MESS (0,25) CALL INPARM ('NEQN',NEQN,1,NEQNMX) LUN = LFORT CALL MESS (1,283) CALL VARNAM(LET1,32,LET2,40,FORB,8,NEQN) IND = MIN(NEQN-1,3) C FINITE DIFFERENCE JACOBIAN? IF (LINEAR) THEN FDIFF = .FALSE. ELSE IF (ITRANS.NE.0) THEN FDIFF = .TRUE. ELSE CALL MESS (0,27) CALL IFYES (FDIFF) ENDIF IF (FDIFF) THEN CALL TEXT ('FDIFF = .TRUE.') ELSE CALL TEXT ('FDIFF = .FALSE.') ENDIF C PDES DEFINED LUN = LFUNS CALL TEXT (' ') CALL TEXT (' ') CALL TEXT & ('subroutine pdes8z(yd8z,i8z,j8z,kint8z,p1,p2,p38z,t,uu8z)') CALL PREC WRITE (LUN,90) NEQNMX 90 FORMAT (6X,'parameter (neqnmx=',I4,')') IF (EIGEN) WRITE (LUN,95) NEQN 95 FORMAT (6X,'parameter (NEQN=',I4,')') CALL COM (2, ' un8z(1,I),un8z(2,I),... hold'// & ' the (rarely used) values') CALL COM (2, ' of UI,UI1,... from the previous'// & ' iteration or time step') IF (DP) THEN CALL TEXT ('common /dtdp5x/un8z(10,neqnmx)') CALL TEXT ('common /dtdp18/norm1,norm2,n38z') CALL TEXT ('double precision norm1,norm2,n38z,'// & 'normx,normy,nz8z') ELSE CALL TEXT ('common / tdp5x/un8z(10,neqnmx)') CALL TEXT ('common / tdp18/norm1,norm2,n38z') CALL TEXT ('real norm1,norm2,n38z,'// & 'normx,normy,nz8z') ENDIF CALL TEXT('dimension uu8z(10,neqnmx)') IF (EIGEN.AND.(NEQN.GT.1)) CALL TEXT('dimension rho(neqn,neqn)') WRITE (LUN,555) (PARNM(I),I=1,NPARN) CALL TEXT ('zr8z = 0.0') DO 230 IEQ = 1,NEQN WRITE (LUN,100) UNK(IEQ)(1:NUNK(IEQ)),IEQ 100 FORMAT(6X,A,' = uu8z(1,',I2,')') WRITE (LUN,110) UNK(IEQ)(1:NUNK(IEQ)),IEQ 110 FORMAT(6X,A,'1 = uu8z(2,',I2,')') WRITE (LUN,120) UNK(IEQ)(1:NUNK(IEQ)),IEQ 120 FORMAT(6X,A,'2 = uu8z(3,',I2,')') WRITE (LUN,140) UNK(IEQ)(1:NUNK(IEQ)),IEQ 140 FORMAT(6X,A,'11= uu8z(5,',I2,')') WRITE (LUN,150) UNK(IEQ)(1:NUNK(IEQ)),IEQ 150 FORMAT(6X,A,'22= uu8z(6,',I2,')') WRITE (LUN,170) UNK(IEQ)(1:NUNK(IEQ)),IEQ 170 FORMAT(6X,A,'12= uu8z(8,',I2,')') WRITE (LUN,180) UNK(IEQ)(1:NUNK(IEQ)),IEQ 180 FORMAT(6X,A,'21= uu8z(8,',I2,')') 230 CONTINUE IF (DP) THEN CALL TEXT ('call dtdpcd(p1,p2,p38z)') CALL TEXT ('call dtdpcb(p1,p2,p38z,norm1,norm2,n38z,'// & 'x,y,z8z,normx,normy,nz8z,3)') ELSE CALL TEXT ('call tdpcd(p1,p2,p38z)') CALL TEXT ('call tdpcb(p1,p2,p38z,norm1,norm2,n38z,'// & 'x,y,z8z,normx,normy,nz8z,3)') ENDIF DO 235 IEQ=1,NEQN IF (DP) THEN CALL TEXT ('call dtdpcc(p1,p2,p38z,') ELSE CALL TEXT ('call tdpcc(p1,p2,p38z,') ENDIF NK = NUNK(IEQ) WRITE (LUN,233) UNK(IEQ)(1:NK),UNK(IEQ)(1:NK), & UNK(IEQ)(1:NK),UNK(IEQ)(1:NK),UNK(IEQ)(1:NK), & UNK(IEQ)(1:NK),UNK(IEQ)(1:NK),UNK(IEQ)(1:NK), & UNK(IEQ)(1:NK),UNK(IEQ)(1:NK),UNK(IEQ)(1:NK) 233 FORMAT (5X,'& ',A,'1,',A,'2,zr8z,',A,'11,', &A,'22,zr8z,',A,'12,zr8z,zr8z,',/,5X,'& x,y,z8z,', &A,'x,',A,'y,uz8z,',A,'xx,',A,'yy,uzz8z,',A,'xy,', &'uxz8z,uyz8z,',/,5X,'& ',A,'yx,uzx8z,uzy8z,dvol,darea)') WRITE (LUN,234) UNK(IEQ)(1:NK),UNK(IEQ)(1:NK), & UNK(IEQ)(1:NK) 234 FORMAT(6X,A,'norm = ',A,'x*normx + ',A,'y*normy') 235 CONTINUE CALL TEXT (' if (i8z.eq.0) then') CALL TEXT ('yd8z = 0.0') LUN = LFORT CALL MESS (0,28) CALL GUI() CALL IREAD ('NINT', NINT, 0, 20) LUN = LFUNS IF (NINT.GT.0) THEN CALL MESS (0,284 + IND) CALL IADD (3, 'the integrals') DO 240 I=1,NINT CALL GUI() CALL VECFUN('INTEGRAL',I,NINT,I,'yd8z',0,'kint8z') 240 CONTINUE ELSE CALL MESS (2,284 + IND) WRITE (LUN,250) 250 FORMAT ('C',50X,'INTEGRAL1 DEFINED',/, & 'C if (kint8z.eq.1) yd8z =',/, & 'C & [DEFAULT SELECTED, DEFINITION COMMENTED OUT]') ENDIF LUN = LFORT CALL MESS (0,74) CALL IREAD ('NBINT', NBINT, 0, 20) LUN = LFUNS IF (NBINT.GT.0) THEN CALL MESS (0,288 + IND) CALL IADD (3, 'the boundary integrals') DO 260 I=1,NBINT CALL VECFUN('BND. INTEGRAL',I,NBINT,(-I),'yd8z',0,'kint8z') 260 CONTINUE ELSE CALL MESS (2,288 + IND) WRITE (LUN,270) 270 FORMAT ('C',50X,'BND. INTEGRAL1 DEFINED',/, & 'C if (kint8z.eq.-1) yd8z =',/, & 'C & [DEFAULT SELECTED, DEFINITION COMMENTED OUT]') ENDIF CALL TEXT ('if (kint8z.gt.0) yd8z = yd8z*dvol') CALL TEXT ('if (kint8z.lt.0) yd8z = yd8z*darea') CALL TEXT (' else') IF (EIGEN) THEN CALL MESS (0,292 + IND) ELSE IF (ELL) THEN CALL MESS (0,296 + IND) ELSE IF (PARA) THEN CALL MESS (0,300 + IND) ENDIF CALL IADD (2,'these coefficients') CALL TEXT (' if (j8z.eq.0) then') CALL TEXT ('yd8z = 0.0') DO 280 I = 1,NEQN IF (PARA) THEN CALL GUI() DO 275 J = 1,NEQN LL = 100*I+J IF (NEQN.EQ.1) THEN CALL VECFUN ('C',1,1,(-LL),'yd8z',2,'i8z') ELSE IF (NEQN.LE.9) THEN WRITE (CNUM6,273) I,J 273 FORMAT ('C(',I1,',',I1,')') CALL VECFUN (CNUM6,1,1,(-LL),'yd8z',2,'i8z') ELSE WRITE (CNUM8,274) I,J 274 FORMAT ('C(',I2,',',I2,')') CALL VECFUN (CNUM8,1,1,(-LL),'yd8z',2,'i8z') ENDIF 275 CONTINUE ENDIF CALL GUI() CALL VECFUN ('F',I,NEQN,I,'yd8z',0,'i8z') IF (EIGEN) THEN CALL GUI() IF (NEQN .EQ. 1) THEN CALL COM (2, & ' RHO DEFINED') CALL INVAR ('RHO', .TRUE.) ELSE CALL COM (2, & ' RHO DEFINED') CALL INMAT ('RHO', I, I, 1, NEQN, .TRUE.) ENDIF ENDIF 280 CONTINUE IF (EIGEN) THEN IF (DP) THEN CALL TEXT ('call dtdpsx (yd8z,i8z,uu8z,un8z,rho,10,neqn)') ELSE CALL TEXT ('call tdpsx (yd8z,i8z,uu8z,un8z,rho,10,neqn)') ENDIF ENDIF CALL TEXT (' else') IF (.NOT.LINEAR .AND. .NOT.FDIFF) THEN DO 285 I = 1,NEQN DO 284 J = 1,NEQN JJ = 10*(J-1) CALL MATFUN('F', I, NEQN, UNK(J)(1:NUNK(J)), & I, JJ+1, 'yd8z', 0) CALL MATFUN('F', I, NEQN, UNK(J)(1:NUNK(J))//'x', & I, JJ+2, 'yd8z', 0) CALL MATFUN('F', I, NEQN, UNK(J)(1:NUNK(J))//'y', & I, JJ+3, 'yd8z', 0) CALL MATFUN('F', I, NEQN, UNK(J)(1:NUNK(J))//'xx', & I, JJ+5, 'yd8z', 0) CALL MATFUN('F', I, NEQN, UNK(J)(1:NUNK(J))//'yy', & I, JJ+6, 'yd8z', 0) CALL MATFUN('F', I, NEQN, UNK(J)(1:NUNK(J))//'xy', & I, JJ+8, 'yd8z', 0) 284 CONTINUE 285 CONTINUE ENDIF CALL TEXT (' endif') CALL TEXT (' endif') CALL TEXT ('return') CALL TEXT ('end') C INITIAL VALUES SPECIFIED CALL TEXT (' ') CALL TEXT (' ') CALL TEXT ('function u8z(i8z,p1,p2,p38z,t0)') CALL PREC WRITE (LUN,555) (PARNM(I),I=1,NPARN) IF (DP) THEN CALL TEXT ('call dtdpcd(p1,p2,p38z)') CALL TEXT ('call dtdpcb(p1,p2,p38z,z18z,z28z,z38z,'// & 'x,y,z8z,d18z,d28z,d38z,1)') ELSE CALL TEXT ('call tdpcd(p1,p2,p38z)') CALL TEXT ('call tdpcb(p1,p2,p38z,z18z,z28z,z38z,'// & 'x,y,z8z,d18z,d28z,d38z,1)') ENDIF IF (EIGEN) THEN IF (DP) THEN CALL TEXT ('u8z = dtdpxx()') ELSE CALL TEXT ('u8z = tdpxx()') ENDIF ELSE CALL TEXT ('u8z = 0.0') ENDIF IF ( .NOT.ELL .OR. .NOT.LINEAR) THEN IF (EIGEN) CALL MESS (0,304) IF (ELL) CALL MESS (0,305) IF (PARA) CALL MESS (0,306) CALL IADD (3,'the initial values') DO 290 I = 1,NEQN IF (EIGEN) THEN CALL VECFUN (UNK(I)(1:NUNK(I))//'0',0,1,I, & 'u8z',1,'i8z') ELSE CALL GUI() CALL VECFUN (UNK(I)(1:NUNK(I))//'0',0,1,I, & 'u8z',2,'i8z') ENDIF 290 CONTINUE LUN = LFORT IF (PARA) THEN CALL MESS (0,158) CALL IFYES(YES) IF (YES) THEN CALL TEXT ('LSQFIT = .TRUE.') ELSE CALL TEXT ('LSQFIT = .FALSE.') ENDIF ELSE CALL TEXT ('lsqfit = .false.') ENDIF CALL MESS (0,48) CALL IFYES(RESTRT) IF (RESTRT) THEN CALL TEXT ('RESTRT = .TRUE.') CALL MESS (0,307) CALL IFYES(YES) IF (YES) THEN CALL TEXT ('GRIDID = .TRUE.') ELSE CALL TEXT ('GRIDID = .FALSE.') ENDIF ELSE CALL TEXT ('RESTRT = .FALSE.') CALL COM (2,'GRIDID = .FALSE. IF FINITE ELEMENT'// & ' GRID CHANGES BETWEEN DUMP, RESTART') CALL TEXT ('GRIDID = .TRUE.') ENDIF ELSE LUN = LFORT CALL TEXT ('lsqfit = .false.') CALL TEXT ('RESTRT = .FALSE.') CALL TEXT ('GRIDID = .TRUE.') ENDIF LUN = LFUNS CALL TEXT ('return') CALL TEXT ('end') C BOUNDARY CONDITIONS DEFINED LUN = LFORT CALL MESS (0,308) CALL GUI() 294 CALL IREAD ('IPERDC',IPERDC,0,4) IF (IPERDC.EQ.3) THEN WRITE (INTOUT,20) GO TO 294 ENDIF IPERDX = 0 IPERDY = 0 IF (IPERDC.EQ.1 .OR. IPERDC.EQ.4) IPERDX = 1 IF (IPERDC.EQ.2 .OR. IPERDC.EQ.4) IPERDY = 1 LUN = LFUNS CALL TEXT (' ') CALL TEXT (' ') CALL TEXT & ('subroutine gb8z(gd8z,ifac8z,i8z,j8z,p1,p2,p38z,t,uu8z)') CALL PREC WRITE (LUN,90) NEQNMX CALL TEXT ('dimension uu8z(10,neqnmx)') CALL COM (2, ' un8z(1,I),un8z(2,I),... hold'// & ' the (rarely used) values') CALL COM (2, ' of UI,UI1,... from the previous'// & ' iteration or time step') IF (DP) THEN CALL TEXT ('common /dtdp5x/ un8z(10,neqnmx)') CALL TEXT ('common /dtdp18/norm1,norm2,n38z') CALL TEXT & ('double precision none,norm1,norm2,n38z,normx,normy,nz8z') WRITE (LUN,555) (PARNM(I),I=1,NPARN) CALL TEXT ('none = dtdplx(2)') ELSE CALL TEXT ('common / tdp5x/ un8z(10,neqnmx)') CALL TEXT ('common / tdp18/norm1,norm2,n38z') CALL TEXT & ('real none,norm1,norm2,n38z,normx,normy,nz8z') WRITE (LUN,555) (PARNM(I),I=1,NPARN) CALL TEXT ('none = tdplx(2)') ENDIF CALL TEXT ('zr8z = 0.0') DO 300 IEQ = 1,NEQN WRITE (LUN,100) UNK(IEQ)(1:NUNK(IEQ)),IEQ WRITE (LUN,110) UNK(IEQ)(1:NUNK(IEQ)),IEQ WRITE (LUN,120) UNK(IEQ)(1:NUNK(IEQ)),IEQ 300 CONTINUE IF (DP) THEN CALL TEXT ('call dtdpcd(p1,p2,p38z)') CALL TEXT ('call dtdpcb(p1,p2,p38z,norm1,norm2,n38z,'// & 'x,y,z8z,normx,normy,nz8z,3)') ELSE CALL TEXT ('call tdpcd(p1,p2,p38z)') CALL TEXT ('call tdpcb(p1,p2,p38z,norm1,norm2,n38z,'// & 'x,y,z8z,normx,normy,nz8z,3)') ENDIF DO 305 IEQ=1,NEQN IF (DP) THEN CALL TEXT ('call dtdpcb(') ELSE CALL TEXT ('call tdpcb(') ENDIF NK = NUNK(IEQ) WRITE (LUN,304) UNK(IEQ)(1:NK),UNK(IEQ)(1:NK), & UNK(IEQ)(1:NK),UNK(IEQ)(1:NK) 304 FORMAT (5X,'& p1,p2,p38z,',A,'1,',A,'2,','zr8z,', & 'x,y,z8z,',A,'x,',A,'y,','uz8z,2)') WRITE (LUN,234) UNK(IEQ)(1:NK),UNK(IEQ)(1:NK), & UNK(IEQ)(1:NK) 305 CONTINUE CALL TEXT ('if (j8z.eq.0) gd8z = 0.0') CALL MESS (0,309 + IND) DO 360 IFACE = 1,4 WRITE (LUN,310) IFACE 310 FORMAT (12X,'if (ifac8z.eq.',I2,') then') CALL MESS (0,313 + IFACE - 1) IF (IFACE.EQ.1 .OR. IFACE.EQ.2) THEN IPER = IPERDX NGRID = NP1GRID ELSE IF (IFACE.EQ.3 .OR. IFACE.EQ.4) THEN IPER = IPERDY NGRID = NP2GRID ENDIF IF (IPER.EQ.0 .AND. NGRID.GT.1) THEN CALL IADD (3,'the boundary conditions (on this face only)') CALL TEXT (' if (j8z.eq.0) then') IDEF = 0 ELSE IF (IPER.EQ.1) THEN WRITE (INTOUT,320) IPERDC 320 FORMAT (/,' IPERDC = ',I1, & ', so periodic boundary conditions set automatically') CALL PAWS CALL TEXT (' if (j8z.eq.0) then') CALL COM (2, & ' PERIODIC BOUNDARY CONDITIONS SET (SEE IPERDC)') IDEF = 3 ELSE WRITE (INTOUT,325) 325 FORMAT (/,' No boundary conditions required on this face') CALL PAWS CALL TEXT (' if (j8z.eq.0) then') CALL COM (2, & ' NO BOUNDARY CONDITIONS REQUIRED ON THIS FACE') IDEF = 3 ENDIF DO 330 I = 1,NEQN IF (IDEF.EQ.0) CALL GUI() CALL VECFUN ('G',I,NEQN,I,'gd8z',IDEF,'i8z') 330 CONTINUE CALL TEXT (' else') IF (.NOT.LINEAR .AND. .NOT.FDIFF) THEN DO 350 I = 1,NEQN DO 340 J = 1,NEQN JJ = 10*(J-1) CALL MATFUN('G', I, NEQN, UNK(J)(1:NUNK(J)), & I, JJ+1, 'gd8z', IDEF) CALL MATFUN('G', I, NEQN, UNK(J)(1:NUNK(J))//'x', & I, JJ+2, 'gd8z', IDEF) CALL MATFUN('G', I, NEQN, UNK(J)(1:NUNK(J))//'y', & I, JJ+3, 'gd8z', IDEF) 340 CONTINUE 350 CONTINUE ENDIF CALL TEXT (' endif') CALL TEXT (' endif') 360 CONTINUE C CALL TEXT ('return') CALL TEXT ('end') C OUTPUT MODIFICATION FUNCTIONS DEFINED LUN = LFUNS CALL TEXT (' ') CALL TEXT (' ') CALL TEXT ('subroutine pmod8z(p1,p2,p38z,t,uu8z,uprint,uxprint,'// & 'uyprint,uzp8z)') CALL PREC CALL TEXT ('dimension uu8z(10,*),uprint(*),uxprint(*),'// & 'uyprint(*),uzp8z(*)') IF (DP) THEN CALL TEXT & ('common/dtdp14/sint(20),bint(20),slim8z(20),blim8z(20)') ELSE CALL TEXT & ('common/ tdp14/sint(20),bint(20),slim8z(20),blim8z(20)') ENDIF WRITE (LUN,555) (PARNM(I),I=1,NPARN) CALL TEXT ('zr8z = 0.0') DO 370 IEQ = 1,NEQN WRITE (LUN,100) UNK(IEQ)(1:NUNK(IEQ)),IEQ WRITE (LUN,110) UNK(IEQ)(1:NUNK(IEQ)),IEQ WRITE (LUN,120) UNK(IEQ)(1:NUNK(IEQ)),IEQ WRITE (LUN,140) UNK(IEQ)(1:NUNK(IEQ)),IEQ WRITE (LUN,150) UNK(IEQ)(1:NUNK(IEQ)),IEQ WRITE (LUN,170) UNK(IEQ)(1:NUNK(IEQ)),IEQ WRITE (LUN,180) UNK(IEQ)(1:NUNK(IEQ)),IEQ 370 CONTINUE IF (DP) THEN CALL TEXT ('call dtdpcd(p1,p2,p38z)') ELSE CALL TEXT ('call tdpcd(p1,p2,p38z)') ENDIF DO 375 IEQ=1,NEQN IF (DP) THEN CALL TEXT ('call dtdpcc(p1,p2,p38z,') ELSE CALL TEXT ('call tdpcc(p1,p2,p38z,') ENDIF NK = NUNK(IEQ) WRITE (LUN,371) UNK(IEQ)(1:NK),UNK(IEQ)(1:NK), & UNK(IEQ)(1:NK),UNK(IEQ)(1:NK),UNK(IEQ)(1:NK), & UNK(IEQ)(1:NK),UNK(IEQ)(1:NK),UNK(IEQ)(1:NK), & UNK(IEQ)(1:NK),UNK(IEQ)(1:NK),UNK(IEQ)(1:NK) 371 FORMAT (5X,'& ',A,'1,',A,'2,zr8z,',A,'11,', &A,'22,zr8z,',A,'12,zr8z,zr8z,',/,5X,'& x,y,z8z,', &A,'x,',A,'y,uz8z,',A,'xx,',A,'yy,uzz8z,',A,'xy,', &'uxz8z,uyz8z,',/,5X,'& ',A,'yx,uzx8z,uzy8z,dvol8z,dare8z)') WRITE (LUN,372) IEQ,UNK(IEQ)(1:NK),IEQ,UNK(IEQ)(1:NK) 372 FORMAT (6X,'uxprint(',i2,') = ',A,'x',/, & 6X,'uyprint(',i2,') = ',A,'y') 375 CONTINUE CALL MESS (0,319 + IND) CALL IADD (3,'these variables') CALL COM (2, ' DEFINE UPRINT(*),UXPRINT(*),'// & 'UYPRINT(*) HERE:') DO 400 I=1,NEQN WRITE (INTOUT,380) UNK(I)(1:NUNK(I)) 380 FORMAT (' Replace ',A,' for postprocessing?') CALL INVEC ('UPRINT',I,I,.FALSE.) WRITE (INTOUT,385) UNK(I)(1:NUNK(I)) 385 FORMAT (' Replace ',A,'x for postprocessing?') CALL INVEC ('UXPRINT',I,I,.FALSE.) WRITE (INTOUT,390) UNK(I)(1:NUNK(I)) 390 FORMAT (' Replace ',A,'y for postprocessing?') CALL INVEC ('UYPRINT',I,I,.FALSE.) 400 CONTINUE CALL TEXT ('return') CALL TEXT ('end') C CALCULATE STORAGE REQUIREMENTS LUN = LPARAM CALL TEXT ('parameter (np3grid = 1)') CALL COM (2,' DIMENSIONS OF WORK ARRAYS') IRWK = 1 IIWK = 1 CALL COM (2, ' SET TO 1 FOR AUTOMATIC ALLOCATION') WRITE (LUN,410) IRWK,IIWK 410 FORMAT (6X,'PARAMETER (IRWK8Z=',I12,')',/, 6X,'PARAMETER (IIWK8Z=' &,I12,')') CALL TEXT & ('PARAMETER (NXP8Z=101,NYP8Z=101,KDEG8Z=1,NZP8Z=KDEG8Z+1)') C OUTPUT PARAMETERS CALL MESS (0,323) CALL INPARM ('NP1',NP1,1,INF) CALL INPARM ('NP2',NP2,0,INF) LUN = LFORT IF (NP2.EQ.0) THEN CALL TEXT ('npts8z = np1+1') CALL MESS (0,324) CALL IADD (0, ' ') CALL STATE(ISTAT) WRITE (LUN,411) ISTAT 411 FORMAT (6X,'do ',I5,' i8z=0,np1') CALL TEXT (' p3out8z(i8z,0) = 0') WRITE (LUN,630) ISTAT ELSE CALL MESS (0,325) CALL COM (2,' defaults for p1a,p1b,p2a,p2b') CALL TEXT ('p1a = p1grid(1)') CALL TEXT ('p1b = p1grid(np1grid)') CALL TEXT ('p2a = p2grid(1)') CALL TEXT ('p2b = p2grid(np2grid)') CALL COM (2,' DEFINE P1A,P1B,P2A,P2B IMMEDIATELY BELOW:') CALL INVAR ('P1A',.FALSE.) CALL INVAR ('P1B',.FALSE.) CALL INVAR ('P2A',.FALSE.) CALL INVAR ('P2B',.FALSE.) IF (DP) THEN CALL TEXT ('call dtdpx3(np1,np2,0,p1a,p1b,p2a,p2b,zr8z,'// & 'zr8z,hp18z,hp28z,hp38z,p1out8z,p2out8z,p3out8z,npts8z)') ELSE CALL TEXT ('call tdpx3(np1,np2,0,p1a,p1b,p2a,p2b,zr8z,'// & 'zr8z,hp18z,hp28z,hp38z,p1out8z,p2out8z,p3out8z,npts8z)') ENDIF ENDIF IF (PARA) THEN LUN = LPARAM CALL MESS (0,53) CALL INPARM ('NSAVE', NSAVE, 1, INF) LUN = LFORT ELSE LUN = LPARAM NSAVE = 1 CALL TEXT ('PARAMETER (NSAVE = 1)') LUN = LFORT CALL COM (2, ' SOLUTION SAVED EVERY NOUT ITERATIONS') CALL TEXT ('NOUT = NSTEPS') ENDIF IF (DP) THEN CALL TEXT ('call dtdpqx(np1grid,np2grid,np3grid,'// & 'isolve,neqn,ii8z,ir8z,iperdc)') ELSE CALL TEXT ('call tdpqx(np1grid,np2grid,np3grid,'// & 'isolve,neqn,ii8z,ir8z,iperdc)') ENDIF CALL TEXT ('if (iiwk8z.gt.1) ii8z = iiwk8z') CALL TEXT ('if (irwk8z.gt.1) ir8z = irwk8z') CALL COM (2, ' *******allocate workspace') CALL TEXT ('allocate (iwrk8z(ii8z),rwrk8z(ir8z))') CALL COM (2,' *******DRAW GRID LINES?') CALL TEXT ('PLOT = .TRUE.') CALL COM (2,' *******call pde solver') IF (DP) THEN CALL TEXT ('call dtdp3x(p1grid, p2grid, p3grid, np1grid,'// & 'np2grid, -1, neqn, p1out8z, p2out8z, p3out8z, uout, tout8z,'// & ' npts8z, t0, dt, nsteps, nout, nsave, crankn, noupdt,'// & ' itype, linear, isolve, rwrk8z, ir8z, iwrk8z, ii8z,'// & ' iperdc, plot, lsqfit, fdiff, nint, nbint, restrt, gridid)') ELSE CALL TEXT ('call tdp3x(p1grid, p2grid, p3grid, np1grid,'// & 'np2grid, -1, neqn, p1out8z, p2out8z, p3out8z, uout, tout8z,'// & ' npts8z, t0, dt, nsteps, nout, nsave, crankn, noupdt,'// & ' itype, linear, isolve, rwrk8z, ir8z, iwrk8z, ii8z,'// & ' iperdc, plot, lsqfit, fdiff, nint, nbint, restrt, gridid)') ENDIF CALL TEXT ('deallocate (iwrk8z,rwrk8z)') IF (EIGEN) THEN WRITE (LUN,412) IST999 412 FORMAT (6X,'if (itype.eq.4) go to ',I5) CALL COM (2, & ' *******UNCOMMENT TO POSTPROCESS ONLY IF CONVERGED') WRITE (LUN,415) IST999 415 FORMAT ('C',6X,'IF (.NOT.ECON8Z) GO TO ',I5) ENDIF IF (ELL.AND.(.NOT.LINEAR)) THEN CALL COM (2, & ' *******UNCOMMENT TO POSTPROCESS ONLY IF CONVERGED') WRITE (LUN,416) IST999 416 FORMAT ('C',6X,'IF (.NOT.NCON8Z) GO TO ',I5) ENDIF IF (DP) THEN CALL COM (2, & ' *******read from restart file to array ures8z') CALL COM (2,' call dtdpr3(1,xres8z,nxp8z,yres8z,nyp8z,'// & 'zres8z,nzp8z,ures8z,neqn)') CALL COM (2, & ' *******write array ures8z back to restart file') CALL COM (2,' call dtdpr3(2,xres8z,nxp8z,yres8z,nyp8z,'// & 'zres8z,nzp8z,ures8z,neqn)') ELSE CALL COM (2, & ' *******read from restart file to array ures8z') CALL COM (2,' call tdpr3(1,xres8z,nxp8z,yres8z,nyp8z,'// & 'zres8z,nzp8z,ures8z,neqn)') CALL COM (2, & ' *******write array ures8z back to restart file') CALL COM (2,' call tdpr3(2,xres8z,nxp8z,yres8z,nyp8z,'// & 'zres8z,nzp8z,ures8z,neqn)') ENDIF CALL COM (2,' *******call user-written postprocessor') CALL TEXT ('call '// & 'postpr(tout8z,nsave,p1out8z,p2out8z,np1,np2,uout,neqn)') LUN = LFUNS CALL TEXT (' ') CALL TEXT (' ') CALL TEXT ('function axis8z(i8z,p1,p2,p38z,ical8z)') CALL PREC IF (DP) THEN CALL TEXT ('call dtdpcd(p1,p2,p38z)') CALL TEXT ('call dtdpcb(p1,p2,p38z,z18z,z28z,z38z,'// & 'x,y,z8z,d18z,d28z,d38z,1)') ELSE CALL TEXT ('call tdpcd(p1,p2,p38z)') CALL TEXT ('call tdpcb(p1,p2,p38z,z18z,z28z,z38z,'// & 'x,y,z8z,d18z,d28z,d38z,1)') ENDIF CALL TEXT ('if (i8z.eq.1) axis8z = x') CALL TEXT ('if (i8z.eq.2) axis8z = y') CALL TEXT ('return') CALL TEXT ('end') LUN = LFORT 420 CONTINUE CALL MESS (1,326) IPLIM = 5 IF (NP2.EQ.0) IPLIM = 1 CALL IREAD (' ',IPLOT,0,IPLIM) IF (IPLOT .EQ. 0) THEN GO TO 460 ELSE IF (IPLOT .EQ. 1) THEN C TABLE OF VALUES AT OUTPUT POINTS CALL COM (2,' *******TABULAR OUTPUT') CALL MESS (0,327 + IND) CALL IREAD ('IVAR',IVAR,1,3*NEQN) CALL TEXT ('ivara8z = mod(ivar-1,3)+1') CALL TEXT ('ivarb8z = (ivar-1)/3+1') IF (.NOT.PARA) THEN CALL TEXT ('ISET1 = 1') CALL TEXT ('ISET2 = NSAVE') CALL TEXT ('ISINC = 1') ELSE CALL MESS (0,123) CALL TEXT ('ISET1 = 0') CALL TEXT ('ISET2 = NSAVE') CALL TEXT ('ISINC = 1') CALL INVAR ('ISET1',.FALSE.) CALL INVAR ('ISET2',.FALSE.) CALL INVAR ('ISINC',.FALSE.) ENDIF CALL MESS (0,59) CALL TEXT ('TITLE = '' '' ') CALL INSTR ('TITLE',.FALSE.) CALL STATE (ISTAT) IF (DP) THEN CALL TEXT('call dtdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,610) ISTAT CALL TEXT ('call dtdprc(p1out8z,p2out8z,uout(0,0,'// & 'ivara8z,ivarb8z,is8z),npts8z,title,tout8z(is8z))') ELSE CALL TEXT('call tdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,610) ISTAT CALL TEXT ('call tdprc(p1out8z,p2out8z,uout(0,0,'// & 'ivara8z,ivarb8z,is8z),npts8z,title,tout8z(is8z))') ENDIF WRITE (LUN,630) ISTAT ELSE IF (IPLOT .EQ. 2) THEN C CROSS-SECTION PLOTS CALL COM (2,' *******SURFACE PLOTS') CALL MESS (0,327 + IND) CALL IREAD ('IVAR',IVAR,1,3*NEQN) CALL TEXT ('ivara8z = mod(ivar-1,3)+1') CALL TEXT ('ivarb8z = (ivar-1)/3+1') IF (.NOT.PARA) THEN CALL TEXT ('ISET1 = 1') CALL TEXT ('ISET2 = NSAVE') CALL TEXT ('ISINC = 1') ELSE CALL MESS (0,123) CALL TEXT ('ISET1 = 0') CALL TEXT ('ISET2 = NSAVE') CALL TEXT ('ISINC = 1') CALL INVAR ('ISET1',.FALSE.) CALL INVAR ('ISET2',.FALSE.) CALL INVAR ('ISINC',.FALSE.) ENDIF CALL MESS (0,127) CALL TEXT ('VLON = 45.0') CALL TEXT ('VLAT = 45.0') CALL INVAR ('VLAT',.FALSE.) CALL INVAR ('VLON',.FALSE.) CALL COM (2,' ') CALL TEXT ('ivar8z = 4*(ivarb8z-1)+ivara8z') CALL TEXT ('alow = amin8z(ivar8z)') CALL TEXT ('ahigh = amax8z(ivar8z)') CALL MESS (0,126) CALL TEXT ('UMIN = 0.0') CALL TEXT ('UMAX = 0.0') CALL INVAR ('UMIN',.FALSE.) CALL INVAR ('UMAX',.FALSE.) CALL MESS (0,59) CALL TEXT ('TITLE = '' '' ') CALL INSTR ('TITLE',.FALSE.) CALL STATE (ISTAT2) IF (DP) THEN CALL TEXT('call dtdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,610) ISTAT2 CALL TEXT ('call dtdplo(p1out8z,p2out8z,p3out8z,'// & 'uout(0,0,ivara8z,ivarb8z,is8z),np1,np2,0,3,ix8z,'// & 'jy8z,0,title,vlon,vlat,umin,umax,tout8z(is8z))') ELSE CALL TEXT('call tdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,610) ISTAT2 CALL TEXT ('call tdplo(p1out8z,p2out8z,p3out8z,'// & 'uout(0,0,ivara8z,ivarb8z,is8z),np1,np2,0,3,ix8z,'// & 'jy8z,0,title,vlon,vlat,umin,umax,tout8z(is8z))') ENDIF WRITE (LUN,630) ISTAT2 ELSE IF (IPLOT .EQ. 3) THEN C CROSS-SECTION PLOTS CALL COM (2,' *******CONTOUR PLOTS') CALL MESS (0,327 + IND) CALL IREAD ('IVAR',IVAR,1,3*NEQN) CALL TEXT ('ivara8z = mod(ivar-1,3)+1') CALL TEXT ('ivarb8z = (ivar-1)/3+1') IF (.NOT.PARA) THEN CALL TEXT ('ISET1 = 1') CALL TEXT ('ISET2 = NSAVE') CALL TEXT ('ISINC = 1') ELSE CALL MESS (0,123) CALL TEXT ('ISET1 = 0') CALL TEXT ('ISET2 = NSAVE') CALL TEXT ('ISINC = 1') CALL INVAR ('ISET1',.FALSE.) CALL INVAR ('ISET2',.FALSE.) CALL INVAR ('ISINC',.FALSE.) ENDIF CALL MESS (0,260) CALL IFYES (YES) IF (YES) THEN CALL TEXT ('NODIST = .TRUE.') ELSE CALL TEXT ('NODIST = .FALSE.') ENDIF CALL COM (2,' ') CALL TEXT ('ivar8z = 4*(ivarb8z-1)+ivara8z') CALL TEXT ('alow = amin8z(ivar8z)') CALL TEXT ('ahigh = amax8z(ivar8z)') CALL MESS (0,261) CALL TEXT ('UMIN = 0.0') CALL TEXT ('UMAX = 0.0') CALL INVAR ('UMIN',.FALSE.) CALL INVAR ('UMAX',.FALSE.) CALL MESS (0,262) CALL IFYES (YES) IF (YES) THEN CALL TEXT ('FILLIN = .TRUE.') ELSE CALL TEXT ('FILLIN = .FALSE.') ENDIF CALL MESS (0,59) CALL TEXT ('TITLE = '' '' ') CALL INSTR ('TITLE',.FALSE.) CALL STATE (ISTAT2) IF (DP) THEN CALL TEXT('call dtdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,610) ISTAT2 CALL TEXT ('call dtdpln(uout(0,0,ivara8z,ivarb8z,is8z),'// & 'np1,np2,0,p1a,p1b,p2a,p2b,zr8z,zr8z,3,ix8z,jy8z,0,'// & 'title,umin,umax,nodist,fillin,tout8z(is8z),'// & 'zr8z,zr8z,zr8z,zr8z,2,ical8z)') ELSE CALL TEXT('call tdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,610) ISTAT2 CALL TEXT ('call tdpln(uout(0,0,ivara8z,ivarb8z,is8z),'// & 'np1,np2,0,p1a,p1b,p2a,p2b,zr8z,zr8z,3,ix8z,jy8z,0,'// & 'title,umin,umax,nodist,fillin,tout8z(is8z),'// & 'zr8z,zr8z,zr8z,zr8z,2,ical8z)') ENDIF WRITE (LUN,630) ISTAT2 ELSE IF (IPLOT .EQ. 4) THEN C CROSS-SECTION PLOTS CALL COM (2,' *******VECTOR PLOTS') CALL MESS (0,331 + IND) CALL IREAD ('IVAR1', IVAR1, 1, 3*NEQN) CALL IREAD ('IVAR2', IVAR2, 1, 3*NEQN) CALL TEXT ('ivar1a8z = mod(ivar1-1,3)+1') CALL TEXT ('ivar1b8z = (ivar1-1)/3+1') CALL TEXT ('ivar2a8z = mod(ivar2-1,3)+1') CALL TEXT ('ivar2b8z = (ivar2-1)/3+1') IF (.NOT.PARA) THEN CALL TEXT ('ISET1 = 1') CALL TEXT ('ISET2 = NSAVE') CALL TEXT ('ISINC = 1') ELSE CALL MESS (0,123) CALL TEXT ('ISET1 = 0') CALL TEXT ('ISET2 = NSAVE') CALL TEXT ('ISINC = 1') CALL INVAR ('ISET1',.FALSE.) CALL INVAR ('ISET2',.FALSE.) CALL INVAR ('ISINC',.FALSE.) ENDIF CALL MESS (0,260) CALL IFYES (YES) IF (YES) THEN CALL TEXT ('NODIST = .TRUE.') ELSE CALL TEXT ('NODIST = .FALSE.') ENDIF CALL COM (2,' ') CALL TEXT ('ivar18z = 4*(ivar1b8z-1)+ivar1a8z') CALL TEXT ('ivar28z = 4*(ivar2b8z-1)+ivar2a8z') CALL TEXT & ('a1mag = max(abs(amin8z(ivar18z)),abs(amax8z(ivar18z)))') CALL TEXT & ('a2mag = max(abs(amin8z(ivar28z)),abs(amax8z(ivar28z)))') CALL MESS (0,267) CALL TEXT ('VR1MAG = 0.0') CALL TEXT ('VR2MAG = 0.0') CALL INVAR ('VR1MAG', .FALSE.) CALL INVAR ('VR2MAG', .FALSE.) CALL MESS (0,59) CALL TEXT ('TITLE = '' '' ') CALL INSTR ('TITLE',.FALSE.) CALL STATE (ISTAT2) IF (DP) THEN CALL TEXT('call dtdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,610) ISTAT2 CALL TEXT ('call dtdplq(uout(0,0,ivar1a8z,ivar1b8z,is8z),'// & 'uout(0,0,ivar2a8z,ivar2b8z,is8z),uout(0,0,4,1,is8z),'// & 'np1,np2,0,p1a,p1b,p2a,p2b,zr8z,zr8z,3,ix8z,jy8z,0,'// & 'title,vr1mag,vr2mag,zr8z,zr8z,nodist,tout8z(is8z),'// & 'zr8z,zr8z,zr8z,zr8z,2,ical8z)') ELSE CALL TEXT('call tdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,610) ISTAT2 CALL TEXT ('call tdplq(uout(0,0,ivar1a8z,ivar1b8z,is8z),'// & 'uout(0,0,ivar2a8z,ivar2b8z,is8z),uout(0,0,4,1,is8z),'// & 'np1,np2,0,p1a,p1b,p2a,p2b,zr8z,zr8z,3,ix8z,jy8z,0,'// & 'title,vr1mag,vr2mag,zr8z,zr8z,nodist,tout8z(is8z),'// & 'zr8z,zr8z,zr8z,zr8z,2,ical8z)') ENDIF WRITE (LUN,630) ISTAT2 ELSE IF (IPLOT .EQ. 5) THEN C 1D CROSS-SECTION PLOTS CALL COM (2, ' *******1D CROSS-SECTION PLOTS') CALL MESS (0,327 + IND) CALL IREAD ('IVAR', IVAR, 1, 3*NEQN) CALL TEXT ('ivara8z = mod(ivar-1,3)+1') CALL TEXT ('ivarb8z = (ivar-1)/3+1') CALL MESS (1,335) ICSLIM = 3 IF (.NOT.PARA) ICSLIM = 2 CALL IREAD (' ', ICS, 1, ICSLIM) IF (ICS.EQ.1) THEN CALL COM (2, ' P1 IS VARIABLE') CALL TEXT ('ics8z = 1') CALL MESS (0,336) CALL IREAD ('NP2VALS', NP2VALS, 1, 100) CALL INVEC ('P2CROSS', 1, NP2VALS, .TRUE.) ELSE IF (ICS.EQ.2) THEN CALL COM (2, ' P2 IS VARIABLE') CALL TEXT ('ics8z = 2') CALL MESS (0,337) CALL IREAD ('NP1VALS', NP1VALS, 1, 100) CALL INVEC ('P1CROSS', 1, NP1VALS, .TRUE.) ELSE IF (ICS.EQ.3) THEN CALL COM (2, ' T IS VARIABLE') CALL TEXT ('ics8z = 4') CALL MESS (0,338) CALL IREAD ('NP1VALS', NP1VALS, 1, 100) CALL INVEC ('P1CROSS', 1, NP1VALS, .TRUE.) CALL IREAD ('NP2VALS', NP2VALS, 1, 100) CALL INVEC ('P2CROSS', 1, NP2VALS, .TRUE.) ENDIF IF (ICS.LE.2) THEN IF (.NOT.PARA) THEN CALL TEXT ('ISET1 = 1') CALL TEXT ('ISET2 = NSAVE') CALL TEXT ('ISINC = 1') ELSE CALL MESS (0,123) CALL TEXT ('ISET1 = 0') CALL TEXT ('ISET2 = NSAVE') CALL TEXT ('ISINC = 1') CALL INVAR ('ISET1',.FALSE.) CALL INVAR ('ISET2',.FALSE.) CALL INVAR ('ISINC',.FALSE.) ENDIF ENDIF CALL COM (2,' ') CALL TEXT ('ivar8z = 4*(ivarb8z-1)+ivara8z') CALL TEXT ('alow = amin8z(ivar8z)') CALL TEXT ('ahigh = amax8z(ivar8z)') CALL MESS (0,126) CALL TEXT ('UMIN = 0.0') CALL TEXT ('UMAX = 0.0') CALL INVAR ('UMIN', .FALSE.) CALL INVAR ('UMAX', .FALSE.) CALL MESS (0,59) CALL TEXT ('TITLE = '' '' ') CALL INSTR ('TITLE',.FALSE.) CALL STATE (ISTAT2) CALL STATE (ISTAT3) IF (DP) THEN IF (ICS.EQ.1) THEN CALL TEXT('call dtdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,610) ISTAT3 WRITE (LUN,440) ISTAT2 CALL TEXT('call dtdpzx(p2cross(jyv8z),p2a,p2b,np2,jy8z)') ELSE IF (ICS.EQ.2) THEN CALL TEXT('call dtdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,610) ISTAT3 WRITE (LUN,430) ISTAT2 CALL TEXT('call dtdpzx(p1cross(ixv8z),p1a,p1b,np1,ix8z)') ELSE IF (ICS.EQ.3) THEN CALL TEXT ('is8z = 0') WRITE (LUN,430) ISTAT3 WRITE (LUN,440) ISTAT2 CALL TEXT('call dtdpzx(p1cross(ixv8z),p1a,p1b,np1,ix8z)') CALL TEXT('call dtdpzx(p2cross(jyv8z),p2a,p2b,np2,jy8z)') ENDIF CALL TEXT ('call dtdppx(ics8z,ivar8z,tout8z,nsave,'// & 'p1out8z,p2out8z,p3out8z,np1,np2,0,uout,neqn,title,'// & 'umin,umax,ix8z,jy8z,0,is8z)') ELSE IF (ICS.EQ.1) THEN CALL TEXT('call tdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,610) ISTAT3 WRITE (LUN,440) ISTAT2 CALL TEXT('call tdpzx(p2cross(jyv8z),p2a,p2b,np2,jy8z)') ELSE IF (ICS.EQ.2) THEN CALL TEXT('call tdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,610) ISTAT3 WRITE (LUN,430) ISTAT2 CALL TEXT('call tdpzx(p1cross(ixv8z),p1a,p1b,np1,ix8z)') ELSE IF (ICS.EQ.3) THEN CALL TEXT ('is8z = 0') WRITE (LUN,430) ISTAT3 WRITE (LUN,440) ISTAT2 CALL TEXT('call tdpzx(p1cross(ixv8z),p1a,p1b,np1,ix8z)') CALL TEXT('call tdpzx(p2cross(jyv8z),p2a,p2b,np2,jy8z)') ENDIF CALL TEXT ('call tdppx(ics8z,ivar8z,tout8z,nsave,'// & 'p1out8z,p2out8z,p3out8z,np1,np2,0,uout,neqn,title,'// & 'umin,umax,ix8z,jy8z,0,is8z)') ENDIF WRITE (LUN,630) ISTAT2 WRITE (LUN,630) ISTAT3 ENDIF GO TO 420 430 FORMAT (6X,'do ',I5,' ixv8z=1,np1vals') 440 FORMAT (6X,'do ',I5,' jyv8z=1,np2vals') 460 CONTINUE LUN = LFUNS C ADD DUMMY PDE2D FUNCTIONS CALL COM (2,' dummy routines') CALL TEXT ('subroutine xy8z(i8z,iarc8z,s,x,y,s0,sf)') CALL PREC CALL TEXT ('return') CALL TEXT ('end') CALL TEXT ('subroutine dis8z(x,y,ktri,triden,shape)') CALL PREC CALL TEXT ('return') CALL TEXT ('end') CALL TEXT ('function fb8z(i8z,iarc8z,ktri,s,x,y,t)') CALL PREC CALL TEXT ('fb8z = 0') CALL TEXT ('return') CALL TEXT ('end') C WRITE POSTPR CALL TEXT (' ') CALL TEXT (' ') CALL TEXT ( &'subroutine postpr(tout,nsave,p1out,p2out,np1,np2,uout,neqn)') CALL PREC CALL TEXT & ('dimension p1out(0:np1,0:np2),p2out(0:np1,0:np2),tout(0:nsave)') CALL TEXT ('dimension uout(0:np1,0:np2,4,neqn,0:nsave)') WRITE (LUN,555) (PARNM(I),I=1,NPARN) IF (DP) THEN CALL TEXT ('common /dtdp27/ itask,npes,icomm') CALL TEXT ('common /dtdp46/ eps8z,cgtl8z,npmx8z,itype,near8z') ELSE CALL TEXT ('common / tdp27/ itask,npes,icomm') CALL TEXT ('common / tdp46/ eps8z,cgtl8z,npmx8z,itype,near8z') ENDIF CALL TEXT ('data lun,lud/0,47/') CALL TEXT ('if (itask.gt.0) return') CALL COM (2,'UOUT(I,J,IDER,IEQ,L) = U_IEQ, if IDER=1') CALL COM (2,' Ux_IEQ, if IDER=2') CALL COM (2,' Uy_IEQ, if IDER=3') CALL COM (2,' (possibly as modified by UPRINT,..)') CALL COM (2,' at the point (P1OUT(I,J) , P2OUT(I,J))') CALL COM (2,' at time/iteration TOUT(L).') CALL COM (2,' ******* ADD POSTPROCESSING CODE HERE:') CALL COM (2,' IN THE EXAMPLE BELOW, MATLAB PLOTFILES pde2d.m,') CALL COM (2,' pde2d.rdm CREATED (REMOVE C! COMMENTS TO ACTIVATE)') CALL COM (3,' if (lun.eq.0) then') CALL COM (3,' lun = 46') CALL COM (3,' open (lun,file=''pde2d.m'')') CALL COM (3,' open (lud,file=''pde2d.rdm'')') CALL COM (3, & ' write (lun,*) ''fid = fopen(''''pde2d.rdm'''');''') CALL COM (3,' endif') CALL COM (3,' do 78753 l=0,nsave') IF (DP) THEN CALL COM (3,' if (tout(l).ne.dtdplx(2)) nsave0 = l') ELSE CALL COM (3,' if (tout(l).ne. tdplx(2)) nsave0 = l') ENDIF CALL COM (4,'78753 continue') CALL COM (3,' write (lud,78754) nsave0') CALL COM (3,' write (lud,78754) neqn') CALL COM (3,' write (lud,78754) np1') CALL COM (3,' write (lud,78754) np2') CALL COM (4,'78754 format (i8)') CALL COM (3,' do 78756 i=0,np1') CALL COM (3,' do 78755 j=0,np2') CALL COM (3,' p1 = p1out(i,j)') CALL COM (3,' p2 = p2out(i,j)') CALL COM (3,' p38z = 0.0') IF (DP) THEN CALL COM (3,' call dtdpcd(p1,p2,p38z)') CALL COM (3, & ' call dtdpcb(p1,p2,p38z,z18z,z28z,z38z,x,y,z8z,') ELSE CALL COM (3,' call tdpcd(p1,p2,p38z)') CALL COM (3, & ' call tdpcb(p1,p2,p38z,z18z,z28z,z38z,x,y,z8z,') ENDIF CALL COM (3,'& d18z,d28z,d38z,1)') CALL COM (3,' write (lud,78762) p1,p2,x,y') CALL COM (4,'78755 continue') CALL COM (4,'78756 continue') CALL COM (3,' do 78761 l=0,nsave0') CALL COM (3,' write (lud,78762) tout(l)') CALL COM (3,' do 78760 ieq=1,neqn') CALL COM (3,' do 78759 ider=1,3') CALL COM (3,' do 78758 i=0,np1') CALL COM (3,' do 78757 j=0,np2') CALL COM (3,' write (lud,78762) uout(i,j,ider,ieq,l)') CALL COM (4,'78757 continue') CALL COM (4,'78758 continue') CALL COM (4,'78759 continue') CALL COM (4,'78760 continue') CALL COM (4,'78761 continue') CALL COM (4,'78762 format (e16.8)') CALL COM (2,' ******* WRITE pde2d.m ') CALL COM (3,' call mtdp2dc(itype,lun)') CALL TEXT ('return') CALL TEXT ('end') C ENTER USER-SUPPLIED FUNCTIONS CALL MESS (1,61) CALL IFYES (YES) IF (YES) CALL IADD (0,' ') C CALL TDPT/DTDPT TO INTERPOLATE TABULAR OUTPUT CALL MESS (1,128) CALL IFYES (YES) IF (YES) THEN C 470 CONTINUE CALL MESS (1,339) 480 CONTINUE WRITE (INTOUT,490) 490 FORMAT (' Function name =') CALL READLN (INPT, 6, NOMORE) IF (NOMORE) THEN WRITE (INTOUT,510) GO TO 480 ENDIF DO 500 I = 1,40 IF (INPT(1) .EQ. LET2(I)) GO TO 520 500 CONTINUE WRITE (INTOUT,510) 510 FORMAT ('|---- Illegal function name, re-enter in columns 1-6') GO TO 480 520 CONTINUE WRITE (LUN,530) INPT 530 FORMAT (//,6X,'function ',6A1,'(p1,p2)') CALL PREC CALL MESS (0,340) CALL INPARM ('NWORK', NWORK, 10, INF) CALL TEXT ('dimension work(nwork)') CALL TEXT ('character*40 fname') IF (DP) THEN CALL TEXT ('data work(1) /0.0d0/') ELSE CALL TEXT ('data work(1) /0.0/') ENDIF CALL MESS (0,278) CALL INSTR ('FNAME', .TRUE.) CALL MESS (0,132) CALL TEXT ('ISET = 1') CALL INVAR ('ISET', .FALSE.) CALL MESS (0,133) CALL IREAD ('KDEG', KDEG, 1, 3) IF (DP) THEN WRITE (LUN,540) INPT 540 FORMAT (6X,6A1,' = dtdpt(fname,iset,work,nwork,kdeg,p1,p2)') ELSE WRITE (LUN,550) INPT 550 FORMAT (6X,6A1,' = tdpt(fname,iset,work,nwork,kdeg,p1,p2)') ENDIF CALL TEXT ('return') CALL TEXT ('end') CALL MESS (1,134) CALL IFYES (YES) IF (YES) GO TO 470 C ENDIF CALL MESS (1,411) LUN = LFORT WRITE (LUN,630) IST999 CALL TEXT ('call endgks') CALL TEXT ('stop') CALL TEXT ('end') LUN = LPARAM WRITE (LUN,555) (PARNM(I),I=1,NPARN) 555 FORMAT (6X,'common/parm8z/ pi',6A7,/,(5X,'&',9A7)) C CONCATENATE PARAMETERS FILE, MAIN PROGRAM, AND SUBPROGRAMS REWIND LFORT 560 CONTINUE READ (LFORT,570,END=580) LINE 570 FORMAT (A79) WRITE (LPARAM,570) LINE GO TO 560 580 CONTINUE REWIND LFUNS 590 CONTINUE READ (LFUNS,570,END=600) LINE WRITE (LPARAM,570) LINE GO TO 590 600 CONTINUE 610 FORMAT (6X,'do ',I5,' is8z=iset1,iset2,isinc') 630 FORMAT (I5,' continue') STOP END SUBROUTINE PDE3D PARAMETER (NEQNMX=99) LOGICAL YES,PARA,ELL,EIGEN,LINEAR,NOMORE,EVCMPX,DP, & RESTRT,FDIFF,UNCOM COMMON /EXMP/ LEVEL,IEXMP,DP COMMON /LUNITS/ INTIN,INTOUT,LMESS,LUN,LPARAM,LFORT,LFUNS,INFIL & ,IECHO COMMON /UNKNWN/ NUNK(NEQNMX),UNK(NEQNMX) COMMON /PARMS/ LSCREN,ISMX2D,ISMX3D,UNCOM C CHARACTER VARIABLES CHARACTER*79 LINE CHARACTER*8 CNUM8 CHARACTER*7 PARNM(176) CHARACTER*6 CNUM6 CHARACTER*3 UNK,FORB(42) CHARACTER*1 INPT(6),LET1(44),LET2(52) DATA LET1 / & 'A','B','C','D','E','F','G','H','O','Q','R','S','U','V','W', & 'a','b','c','d','e','f','g','h','o','q','r','s','u','v','w', & 'I','J','K','L','M','N','P','i','j','k','l','m','n','p'/ DATA LET2 / 'A','B','C','D','E','F','G','H','O','P', & 'Q','R','S','T','U','V','W','X','Y','Z', & 'a','b','c','d','e','f','g','h','o','p', & 'q','r','s','t','u','v','w','x','y','z', & 'I','J','K','L','M','N','i','j','k','l','m','n'/ DATA FORB/ &'P1 ','p1 ','P2 ','p2 ','P3 ','p3 ','PI ','Pi ','pI ','pi ', &'DT ','TF ','Dt ','Tf ','dT ','tF ','dt ','tf ','T0 ','t0 ', &'NC ','Nc ','nC ','nc ','X1 ','x1 ','X2 ','x2 ','X3 ','x3 ', &'Y1 ','y1 ','Y2 ','y2 ','Y3 ','y3 ','Z1 ','z1 ','Z2 ','z2 ', &'Z3 ','z3 '/ C INF = 10000 CALL COM (2,'*** 3D PROBLEM SOLVED ***') CALL MESS (0,7) CALL IFYES (DP) CALL PREC WRITE (LUN,90) NEQNMX LUN = LFORT CALL TEXT ('dimension p1grid(np1grid),p2grid(np2grid),'// & 'p3grid(np3grid),p1out8z(0:np1,0:np2,0:np3),'// & 'p2out8z(0:np1,0:np2,0:np3),p3out8z(0:np1,0:np2,0:np3),'// & 'p1cross(100),p2cross(100),p3cross(100),tout8z(0:nsave)') CALL COM (2, & ' dimension xres8z(nxp8z),yres8z(nyp8z),zres8z(nzp8z),') CALL COM (2,'& ures8z(neqn,nxp8z,nyp8z,nzp8z)') CALL TEXT ('allocatable iwrk8z(:),rwrk8z(:)') CALL COM (2,' dimension iwrk8z(iiwk8z),rwrk8z(irwk8z)') CALL TEXT ('character*40 title') CALL TEXT ('logical linear,crankn,noupdt,nodist,fillin,'// & 'evcmpx,adapt,plot,lsqfit,fdiff,solid,econ8z,ncon8z,restrt,'// & 'gridid') IF (DP) THEN CALL TEXT & ('common/dtdp14/ sint8z(20),bint8z(20),slim8z(20),blim8z(20)') CALL TEXT ('common/dtdp15/ evlr8z,ev0r,evli8z,ev0i,evcmpx') CALL TEXT ('common/dtdp16/ p8z,evr8z(50),evi8z(50)') CALL TEXT ('common/dtdp19/ toler(neqnmx),adapt') CALL TEXT ('common/dtdp30/ econ8z,ncon8z') CALL TEXT ('common/dtdp45/ perdc(neqnmx)') CALL TEXT ('common/dtdp46/ eps8z,cgtl8z,npmx8z,itype,near8z') CALL TEXT ('common/dtdp52/ nxa8z,nya8z,nza8z,kd8z') CALL TEXT ('common/dtdp53/ work8z(nxp8z*nyp8z*nzp8z+9)') CALL TEXT ('common/dtdp64/ amin8z(4*neqnmx),amax8z(4*neqnmx)') CALL TEXT ('common/dtdp77/ nx18z,ny18z,nz18z,p1a,p1b,p2a,'// & 'p2b,p3a,p3b,uout(0:np1,0:np2,0:np3,4,neqn,0:nsave)') ELSE CALL TEXT & ('common/ tdp14/ sint8z(20),bint8z(20),slim8z(20),blim8z(20)') CALL TEXT ('common/ tdp15/ evlr8z,ev0r,evli8z,ev0i,evcmpx') CALL TEXT ('common/ tdp16/ p8z,evr8z(50),evi8z(50)') CALL TEXT ('common/ tdp19/ toler(neqnmx),adapt') CALL TEXT ('common/ tdp30/ econ8z,ncon8z') CALL TEXT ('common/ tdp45/ perdc(neqnmx)') CALL TEXT ('common/ tdp46/ eps8z,cgtl8z,npmx8z,itype,near8z') CALL TEXT ('common/ tdp52/ nxa8z,nya8z,nza8z,kd8z') CALL TEXT ('common/ tdp53/ work8z(nxp8z*nyp8z*nzp8z+9)') CALL TEXT ('common/ tdp64/ amin8z(4*neqnmx),amax8z(4*neqnmx)') CALL TEXT ('common/ tdp77/ nx18z,ny18z,nz18z,p1a,p1b,p2a,'// & 'p2b,p3a,p3b,uout(0:np1,0:np2,0:np3,4,neqn,0:nsave)') ENDIF CALL TEXT ('pi = 4.0*atan(1.d0)') CALL TEXT ('nxa8z = nxp8z') CALL TEXT ('nya8z = nyp8z') CALL TEXT ('nza8z = nzp8z') CALL TEXT ('nx18z = np1+1') CALL TEXT ('ny18z = np2+1') CALL TEXT ('nz18z = np3+1') CALL TEXT ('kd8z = kdeg8z') CALL MESS (0,8) CALL TEXT ('NPROB = 1') CALL INVAR ('NPROB',.FALSE.) CALL STATE (IST999) WRITE (LUN,10) IST999 10 FORMAT (6X,'do ',I5,' iprob=1,nprob') CALL MESS (0,341) CALL GUI() CALL GLOBP(LET1,44,LET2,52,FORB,42,PARNM,NPARN) CALL MESS (1,10) CALL IFYES (YES) LEVEL = 2 IF (YES) LEVEL = 3 LUN = LFUNS CALL TEXT (' ') CALL TEXT (' ') CALL TEXT ('subroutine tran8z(itrans,p1,p2,p3)') CALL PREC IF (DP) THEN CALL TEXT ('common /dtdp41/x,y,z,x1,x2,x3,y1,y2,y3'// & ',z1,z2,z3,x11,x21,x31,x12,x22,x32,x13,x23,x33'// & ',y11,y21,y31,y12,y22,y32,y13,y23,y33'// & ',z11,z21,z31,z12,z22,z32,z13,z23,z33') ELSE CALL TEXT ('common / tdp41/x,y,z,x1,x2,x3,y1,y2,y3'// & ',z1,z2,z3,x11,x21,x31,x12,x22,x32,x13,x23,x33'// & ',y11,y21,y31,y12,y22,y32,y13,y23,y33'// & ',z11,z21,z31,z12,z22,z32,z13,z23,z33') ENDIF WRITE (LUN,555) (PARNM(I),I=1,NPARN) CALL MESS (0,342) CALL IREAD ('ITRANS', ITRANS, -3, 3) IF (ITRANS.EQ.3) THEN CALL IADD(3,'X,Y,Z,X1,...') CALL INVAR('X',.TRUE.) CALL INVAR('Y',.TRUE.) CALL INVAR('Z',.TRUE.) CALL SPACER CALL INVAR('X1',.TRUE.) CALL INVAR('X2',.TRUE.) CALL INVAR('X3',.TRUE.) CALL SPACER CALL INVAR('Y1',.TRUE.) CALL INVAR('Y2',.TRUE.) CALL INVAR('Y3',.TRUE.) CALL SPACER CALL INVAR('Z1',.TRUE.) CALL INVAR('Z2',.TRUE.) CALL INVAR('Z3',.TRUE.) CALL SPACER CALL INVAR('X11',.TRUE.) CALL INVAR('X12',.TRUE.) CALL INVAR('X13',.TRUE.) CALL INVAR('X22',.TRUE.) CALL INVAR('X23',.TRUE.) CALL INVAR('X33',.TRUE.) CALL SPACER CALL INVAR('Y11',.TRUE.) CALL INVAR('Y12',.TRUE.) CALL INVAR('Y13',.TRUE.) CALL INVAR('Y22',.TRUE.) CALL INVAR('Y23',.TRUE.) CALL INVAR('Y33',.TRUE.) CALL SPACER CALL INVAR('Z11',.TRUE.) CALL INVAR('Z12',.TRUE.) CALL INVAR('Z13',.TRUE.) CALL INVAR('Z22',.TRUE.) CALL INVAR('Z23',.TRUE.) CALL INVAR('Z33',.TRUE.) ELSE IF (ITRANS.EQ.-3) THEN CALL IADD(3,'X,Y,Z') CALL GUI() CALL INVAR('X',.TRUE.) CALL GUI() CALL INVAR('Y',.TRUE.) CALL GUI() CALL INVAR('Z',.TRUE.) ENDIF CALL TEXT ('return') CALL TEXT ('end') C RECTANGULAR GRID LUN = LFORT CALL MESS (0,343) IF (DP) THEN CALL TEXT ('call dtdpwx(p1grid,np1grid,0)') CALL TEXT ('call dtdpwx(p2grid,np2grid,0)') CALL TEXT ('call dtdpwx(p3grid,np3grid,0)') ELSE CALL TEXT ('call tdpwx(p1grid,np1grid,0)') CALL TEXT ('call tdpwx(p2grid,np2grid,0)') CALL TEXT ('call tdpwx(p3grid,np3grid,0)') ENDIF C LUN = LPARAM CALL COM (1,'NP1GRID = number of P1-grid lines') CALL GUI() CALL INPARM ('NP1GRID',NP1GRID,1,INF) LUN = LFORT CALL COM (2,' P1GRID DEFINED') CALL GUI() CALL INVAR ('P1GRID(1)',.TRUE.) CALL INVEC ('P1GRID',2,NP1GRID - 1,.FALSE.) CALL GUI() IF (NP1GRID.GT.1) CALL INVAR ('P1GRID(NP1GRID)',.TRUE.) C LUN = LPARAM CALL COM (1,'NP2GRID = number of P2-grid lines') CALL GUI() CALL INPARM ('NP2GRID',NP2GRID,1,INF) LUN = LFORT CALL COM (2,' P2GRID DEFINED') CALL GUI() CALL INVAR ('P2GRID(1)',.TRUE.) CALL INVEC ('P2GRID',2,NP2GRID - 1,.FALSE.) CALL GUI() IF (NP2GRID.GT.1) CALL INVAR ('P2GRID(NP2GRID)',.TRUE.) C LUN = LPARAM CALL COM (1,'NP3GRID = number of P3-grid lines') CALL GUI() CALL INPARM ('NP3GRID',NP3GRID,1,INF) LUN = LFORT CALL COM (2,' P3GRID DEFINED') CALL GUI() CALL INVAR ('P3GRID(1)',.TRUE.) CALL INVEC ('P3GRID',2,NP3GRID - 1,.FALSE.) CALL GUI() IF (NP3GRID.GT.1) CALL INVAR ('P3GRID(NP3GRID)',.TRUE.) IF (DP) THEN CALL TEXT ('call dtdpwx(p1grid,np1grid,1)') CALL TEXT ('call dtdpwx(p2grid,np2grid,1)') CALL TEXT ('call dtdpwx(p3grid,np3grid,1)') ELSE CALL TEXT ('call tdpwx(p1grid,np1grid,1)') CALL TEXT ('call tdpwx(p2grid,np2grid,1)') CALL TEXT ('call tdpwx(p3grid,np3grid,1)') ENDIF C LUN = LFORT CALL MESS (0,282) CALL IREAD ('ISOLVE', ISOLVE, 1, ISMX3D) C IDENTIFY TYPE OF PDE CALL MESS (1,11) CALL IREAD (' ',ITYPE,1,3) ELL = ITYPE .EQ. 1 PARA = ITYPE .EQ. 2 EIGEN = ITYPE .EQ. 3 IF (EIGEN) THEN C EIGENVALUE PROBLEM SOLVED CALL COM (2, ' *******EIGENVALUE PROBLEM') CALL MESS (0,12) CALL PAWS CALL TEXT ('ITYPE = 3') CALL COM (2,' ') CALL COM (2,' P8Z = 0.0') LINEAR = .TRUE. CALL TEXT ('linear = .true.') CALL TEXT ('t0 = 0.0') CALL TEXT ('dt = 1.0') CALL TEXT ('crankn = .false.') CALL TEXT ('noupdt = .true.') CALL MESS (0,13) CALL IFYES (EVCMPX) IF (.NOT.EVCMPX) THEN CALL TEXT ('EVCMPX = .FALSE.') CALL MESS (0,14) CALL TEXT ('EV0R = 0.0') CALL GUI() CALL INVAR ('EV0R', .FALSE.) ELSE CALL TEXT ('EVCMPX = .TRUE.') CALL MESS (0,15) CALL TEXT ('EV0R = 0.0') CALL TEXT ('EV0I = 0.0') CALL INVAR ('EV0R', .FALSE.) CALL INVAR ('EV0I', .FALSE.) ENDIF CALL MESS (0,16) CALL TEXT ('NSTEPS = 25') CALL INVAR ('NSTEPS',.FALSE.) ELSE IF (PARA) THEN C TIME DEPENDENT PROBLEM SOLVED CALL COM (2,' *******TIME-DEPENDENT PROBLEM') CALL TEXT ('itype = 2') CALL MESS (0,17) CALL TEXT ('T0 = 0.0') CALL GUI() CALL INVAR ('T0',.FALSE.) CALL GUI() CALL INVAR ('TF',.TRUE.) CALL MESS (0,18) CALL IFYES (LINEAR) IF (LINEAR) THEN CALL TEXT ('LINEAR = .TRUE.') ELSE CALL TEXT ('LINEAR = .FALSE.') ENDIF CALL MESS (0,19) CALL IFYES (YES) CALL GUI() IF (YES) THEN CALL TEXT ('ADAPT = .TRUE.') CALL TEXT ('TOLER(1) = 0.01') CALL INVAR ('TOLER(1)', .FALSE.) IF (LINEAR) CALL MESS (2,20) CALL TEXT ('NOUPDT = .FALSE.') CALL MESS (0,21) ELSE CALL TEXT ('ADAPT = .FALSE.') CALL TEXT ('TOLER(1) = 0.01') IF (LINEAR) THEN CALL MESS (0,20) CALL IFYES (YES) CALL GUI() IF (YES) THEN CALL TEXT ('NOUPDT = .TRUE.') ELSE CALL TEXT ('NOUPDT = .FALSE.') ENDIF ELSE CALL TEXT ('NOUPDT = .FALSE.') ENDIF CALL MESS (0,22) ENDIF CALL GUI() CALL INVAR ('NSTEPS',.TRUE.) CALL TEXT ('dt = (tf-t0)/max(nsteps,1)') CALL MESS (0,65) CALL IFYES (YES) IF (YES) THEN CALL TEXT ('CRANKN = .TRUE.') ELSE CALL TEXT ('CRANKN = .FALSE.') ENDIF ELSE C STEADY STATE PROBLEM SOLVED CALL COM (2,' *******STEADY-STATE PROBLEM') CALL TEXT ('itype = 1') CALL TEXT ('t0 = 0.0') CALL TEXT ('dt = 1.0') CALL TEXT ('crankn = .false.') CALL TEXT ('noupdt = .false.') CALL MESS (0,18) CALL IFYES (LINEAR) IF (LINEAR) THEN CALL TEXT ('LINEAR = .TRUE.') CALL COM (2, ' Number of Newton iterations') CALL TEXT ('NSTEPS = 1') ELSE CALL TEXT ('LINEAR = .FALSE.') CALL MESS (0,24) CALL TEXT ('NSTEPS = 15') CALL INVAR ('NSTEPS',.FALSE.) ENDIF ENDIF LUN = LPARAM CALL MESS (0,25) CALL INPARM ('NEQN',NEQN,1,NEQNMX) LUN = LFORT CALL MESS (1,344) CALL VARNAM(LET1,30,LET2,40,FORB,10,NEQN) IND = MIN(NEQN-1,3) C FINITE DIFFERENCE JACOBIAN? IF (LINEAR) THEN FDIFF = .FALSE. ELSE IF (ITRANS.NE.0) THEN FDIFF = .TRUE. ELSE CALL MESS (0,27) CALL IFYES (FDIFF) ENDIF IF (FDIFF) THEN CALL TEXT ('FDIFF = .TRUE.') ELSE CALL TEXT ('FDIFF = .FALSE.') ENDIF C PDES DEFINED LUN = LFUNS CALL TEXT (' ') CALL TEXT (' ') CALL TEXT & ('subroutine pdes8z(yd8z,i8z,j8z,kint8z,p1,p2,p3,t,uu8z)') CALL PREC WRITE (LUN,90) NEQNMX 90 FORMAT (6X,'parameter (neqnmx=',I4,')') IF (EIGEN) WRITE (LUN,95) NEQN 95 FORMAT (6X,'parameter (NEQN=',I4,')') CALL COM (2, ' un8z(1,I),un8z(2,I),... hold'// & ' the (rarely used) values') CALL COM (2, ' of UI,UI1,... from the previous'// & ' iteration or time step') IF (DP) THEN CALL TEXT ('common /dtdp5x/un8z(10,neqnmx)') CALL TEXT ('common /dtdp18/norm1,norm2,norm3') CALL TEXT ('double precision norm1,norm2,norm3,'// & 'normx,normy,normz') ELSE CALL TEXT ('common / tdp5x/un8z(10,neqnmx)') CALL TEXT ('common / tdp18/norm1,norm2,norm3') CALL TEXT ('real norm1,norm2,norm3,'// & 'normx,normy,normz') ENDIF CALL TEXT('dimension uu8z(10,neqnmx)') IF (EIGEN.AND.(NEQN.GT.1)) CALL TEXT('dimension rho(neqn,neqn)') WRITE (LUN,555) (PARNM(I),I=1,NPARN) DO 230 IEQ = 1,NEQN WRITE (LUN,100) UNK(IEQ)(1:NUNK(IEQ)),IEQ 100 FORMAT(6X,A,' = uu8z(1,',I2,')') WRITE (LUN,110) UNK(IEQ)(1:NUNK(IEQ)),IEQ 110 FORMAT(6X,A,'1 = uu8z(2,',I2,')') WRITE (LUN,120) UNK(IEQ)(1:NUNK(IEQ)),IEQ 120 FORMAT(6X,A,'2 = uu8z(3,',I2,')') WRITE (LUN,130) UNK(IEQ)(1:NUNK(IEQ)),IEQ 130 FORMAT(6X,A,'3 = uu8z(4,',I2,')') WRITE (LUN,140) UNK(IEQ)(1:NUNK(IEQ)),IEQ 140 FORMAT(6X,A,'11= uu8z(5,',I2,')') WRITE (LUN,150) UNK(IEQ)(1:NUNK(IEQ)),IEQ 150 FORMAT(6X,A,'22= uu8z(6,',I2,')') WRITE (LUN,160) UNK(IEQ)(1:NUNK(IEQ)),IEQ 160 FORMAT(6X,A,'33= uu8z(7,',I2,')') WRITE (LUN,170) UNK(IEQ)(1:NUNK(IEQ)),IEQ 170 FORMAT(6X,A,'12= uu8z(8,',I2,')') WRITE (LUN,180) UNK(IEQ)(1:NUNK(IEQ)),IEQ 180 FORMAT(6X,A,'21= uu8z(8,',I2,')') WRITE (LUN,190) UNK(IEQ)(1:NUNK(IEQ)),IEQ 190 FORMAT(6X,A,'13= uu8z(9,',I2,')') WRITE (LUN,200) UNK(IEQ)(1:NUNK(IEQ)),IEQ 200 FORMAT(6X,A,'31= uu8z(9,',I2,')') WRITE (LUN,210) UNK(IEQ)(1:NUNK(IEQ)),IEQ 210 FORMAT(6X,A,'23= uu8z(10,',I2,')') WRITE (LUN,220) UNK(IEQ)(1:NUNK(IEQ)),IEQ 220 FORMAT(6X,A,'32= uu8z(10,',I2,')') 230 CONTINUE IF (DP) THEN CALL TEXT ('call dtdpcd(p1,p2,p3)') CALL TEXT ('call dtdpcb(p1,p2,p3,norm1,norm2,norm3,'// & 'x,y,z,normx,normy,normz,3)') ELSE CALL TEXT ('call tdpcd(p1,p2,p3)') CALL TEXT ('call tdpcb(p1,p2,p3,norm1,norm2,norm3,'// & 'x,y,z,normx,normy,normz,3)') ENDIF DO 235 IEQ=1,NEQN IF (DP) THEN CALL TEXT ('call dtdpcc(p1,p2,p3,') ELSE CALL TEXT ('call tdpcc(p1,p2,p3,') ENDIF NK = NUNK(IEQ) WRITE (LUN,233) UNK(IEQ)(1:NK),UNK(IEQ)(1:NK), & UNK(IEQ)(1:NK),UNK(IEQ)(1:NK),UNK(IEQ)(1:NK), & UNK(IEQ)(1:NK),UNK(IEQ)(1:NK),UNK(IEQ)(1:NK), & UNK(IEQ)(1:NK),UNK(IEQ)(1:NK),UNK(IEQ)(1:NK), & UNK(IEQ)(1:NK),UNK(IEQ)(1:NK),UNK(IEQ)(1:NK), & UNK(IEQ)(1:NK),UNK(IEQ)(1:NK),UNK(IEQ)(1:NK), & UNK(IEQ)(1:NK),UNK(IEQ)(1:NK),UNK(IEQ)(1:NK), & UNK(IEQ)(1:NK) 233 FORMAT (5X,'& ',A,'1,',A,'2,',A,'3,',A,'11,', &A,'22,',A,'33,',A,'12,',A,'13,',A,'23,',/,5X,'& x,y,z,', &A,'x,',A,'y,',A,'z,',A,'xx,',A,'yy,',A,'zz,',A,'xy,' &,A,'xz,',A,'yz,',/,5X,'& ',A,'yx,',A,'zx,',A,'zy,dvol,darea)') WRITE (LUN,234) UNK(IEQ)(1:NK),UNK(IEQ)(1:NK), & UNK(IEQ)(1:NK),UNK(IEQ)(1:NK) 234 FORMAT(6X, & A,'norm = ',A,'x*normx + ',A,'y*normy + ',A,'z*normz') 235 CONTINUE CALL TEXT (' if (i8z.eq.0) then') CALL TEXT ('yd8z = 0.0') LUN = LFORT CALL MESS (0,28) CALL GUI() CALL IREAD ('NINT', NINT, 0, 20) LUN = LFUNS IF (NINT.GT.0) THEN CALL MESS (0,345 + IND) CALL IADD (3, 'the integrals') DO 240 I=1,NINT CALL GUI() CALL VECFUN('INTEGRAL',I,NINT,I,'yd8z',0,'kint8z') 240 CONTINUE ELSE CALL MESS (2,345 + IND) WRITE (LUN,250) 250 FORMAT ('C',50X,'INTEGRAL1 DEFINED',/, & 'C if (kint8z.eq.1) yd8z =',/, & 'C & [DEFAULT SELECTED, DEFINITION COMMENTED OUT]') ENDIF LUN = LFORT CALL MESS (0,74) CALL IREAD ('NBINT', NBINT, 0, 20) LUN = LFUNS IF (NBINT.GT.0) THEN CALL MESS (0,349 + IND) CALL IADD (3, 'the boundary integrals') DO 260 I=1,NBINT CALL VECFUN('BND. INTEGRAL',I,NBINT,(-I),'yd8z',0,'kint8z') 260 CONTINUE ELSE CALL MESS (2,349 + IND) WRITE (LUN,270) 270 FORMAT ('C',50X,'BND. INTEGRAL1 DEFINED',/, & 'C if (kint8z.eq.-1) yd8z =',/, & 'C & [DEFAULT SELECTED, DEFINITION COMMENTED OUT]') ENDIF CALL TEXT ('if (kint8z.gt.0) yd8z = yd8z*dvol') CALL TEXT ('if (kint8z.lt.0) yd8z = yd8z*darea') CALL TEXT (' else') IF (EIGEN) THEN CALL MESS (0,353 + IND) ELSE IF (ELL) THEN CALL MESS (0,357 + IND) ELSE IF (PARA) THEN CALL MESS (0,361 + IND) ENDIF CALL IADD (2,'these coefficients') CALL TEXT (' if (j8z.eq.0) then') CALL TEXT ('yd8z = 0.0') DO 280 I = 1,NEQN IF (PARA) THEN CALL GUI() DO 275 J = 1,NEQN LL = 100*I+J IF (NEQN.EQ.1) THEN CALL VECFUN ('C',1,1,(-LL),'yd8z',2,'i8z') ELSE IF (NEQN.LE.9) THEN WRITE (CNUM6,273) I,J 273 FORMAT ('C(',I1,',',I1,')') CALL VECFUN (CNUM6,1,1,(-LL),'yd8z',2,'i8z') ELSE WRITE (CNUM8,274) I,J 274 FORMAT ('C(',I2,',',I2,')') CALL VECFUN (CNUM8,1,1,(-LL),'yd8z',2,'i8z') ENDIF 275 CONTINUE ENDIF CALL GUI() CALL VECFUN ('F',I,NEQN,I,'yd8z',0,'i8z') IF (EIGEN) THEN CALL GUI() IF (NEQN .EQ. 1) THEN CALL COM (2, & ' RHO DEFINED') CALL INVAR ('RHO', .TRUE.) ELSE CALL COM (2, & ' RHO DEFINED') CALL INMAT ('RHO', I, I, 1, NEQN, .TRUE.) ENDIF ENDIF 280 CONTINUE IF (EIGEN) THEN IF (DP) THEN CALL TEXT ('call dtdpsx (yd8z,i8z,uu8z,un8z,rho,10,neqn)') ELSE CALL TEXT ('call tdpsx (yd8z,i8z,uu8z,un8z,rho,10,neqn)') ENDIF ENDIF CALL TEXT (' else') IF (.NOT.LINEAR .AND. .NOT.FDIFF) THEN DO 285 I = 1,NEQN DO 284 J = 1,NEQN JJ = 10*(J-1) CALL MATFUN('F', I, NEQN, UNK(J)(1:NUNK(J)), & I, JJ+1, 'yd8z', 0) CALL MATFUN('F', I, NEQN, UNK(J)(1:NUNK(J))//'x', & I, JJ+2, 'yd8z', 0) CALL MATFUN('F', I, NEQN, UNK(J)(1:NUNK(J))//'y', & I, JJ+3, 'yd8z', 0) CALL MATFUN('F', I, NEQN, UNK(J)(1:NUNK(J))//'z', & I, JJ+4, 'yd8z', 0) CALL MATFUN('F', I, NEQN, UNK(J)(1:NUNK(J))//'xx', & I, JJ+5, 'yd8z', 0) CALL MATFUN('F', I, NEQN, UNK(J)(1:NUNK(J))//'yy', & I, JJ+6, 'yd8z', 0) CALL MATFUN('F', I, NEQN, UNK(J)(1:NUNK(J))//'zz', & I, JJ+7, 'yd8z', 0) CALL MATFUN('F', I, NEQN, UNK(J)(1:NUNK(J))//'xy', & I, JJ+8, 'yd8z', 0) CALL MATFUN('F', I, NEQN, UNK(J)(1:NUNK(J))//'xz', & I, JJ+9, 'yd8z', 0) CALL MATFUN('F', I, NEQN, UNK(J)(1:NUNK(J))//'yz', & I, JJ+10, 'yd8z', 0) 284 CONTINUE 285 CONTINUE ENDIF CALL TEXT (' endif') CALL TEXT (' endif') CALL TEXT ('return') CALL TEXT ('end') C INITIAL VALUES SPECIFIED CALL TEXT (' ') CALL TEXT (' ') CALL TEXT ('function u8z(i8z,p1,p2,p3,t0)') CALL PREC WRITE (LUN,555) (PARNM(I),I=1,NPARN) IF (DP) THEN CALL TEXT ('call dtdpcd(p1,p2,p3)') CALL TEXT ('call dtdpcb(p1,p2,p3,zr18z,zr28z,zr38z,'// & 'x,y,z,d18z,d28z,d38z,1)') ELSE CALL TEXT ('call tdpcd(p1,p2,p3)') CALL TEXT ('call tdpcb(p1,p2,p3,zr18z,zr28z,zr38z,'// & 'x,y,z,d18z,d28z,d38z,1)') ENDIF IF (EIGEN) THEN IF (DP) THEN CALL TEXT ('u8z = dtdpxx()') ELSE CALL TEXT ('u8z = tdpxx()') ENDIF ELSE CALL TEXT ('u8z = 0.0') ENDIF IF ( .NOT.ELL .OR. .NOT.LINEAR) THEN IF (EIGEN) CALL MESS (0,365) IF (ELL) CALL MESS (0,366) IF (PARA) CALL MESS (0,367) CALL IADD (3,'the initial values') DO 290 I = 1,NEQN IF (EIGEN) THEN CALL VECFUN (UNK(I)(1:NUNK(I))//'0',0,1,I, & 'u8z',1,'i8z') ELSE CALL GUI() CALL VECFUN (UNK(I)(1:NUNK(I))//'0',0,1,I, & 'u8z',2,'i8z') ENDIF 290 CONTINUE LUN = LFORT IF (PARA) THEN CALL MESS (0,158) CALL IFYES(YES) IF (YES) THEN CALL TEXT ('LSQFIT = .TRUE.') ELSE CALL TEXT ('LSQFIT = .FALSE.') ENDIF ELSE CALL TEXT ('lsqfit = .false.') ENDIF CALL MESS (0,48) CALL IFYES(RESTRT) IF (RESTRT) THEN CALL TEXT ('RESTRT = .TRUE.') CALL MESS (0,307) CALL IFYES(YES) IF (YES) THEN CALL TEXT ('GRIDID = .TRUE.') ELSE CALL TEXT ('GRIDID = .FALSE.') ENDIF ELSE CALL TEXT ('RESTRT = .FALSE.') CALL COM (2,'GRIDID = .FALSE. IF FINITE ELEMENT'// & ' GRID CHANGES BETWEEN DUMP, RESTART') CALL TEXT ('GRIDID = .TRUE.') ENDIF ELSE LUN = LFORT CALL TEXT ('lsqfit = .false.') CALL TEXT ('RESTRT = .FALSE.') CALL TEXT ('GRIDID = .TRUE.') ENDIF LUN = LFUNS CALL TEXT ('return') CALL TEXT ('end') C BOUNDARY CONDITIONS DEFINED LUN = LFORT CALL MESS (0,368) CALL GUI() CALL IREAD ('IPERDC',IPERDC,0,7) IPERDX = 0 IPERDY = 0 IPERDZ = 0 IF (IPERDC.EQ.1 .OR. IPERDC.EQ.4 .OR. & IPERDC.EQ.5 .OR. IPERDC.EQ.7) IPERDX = 1 IF (IPERDC.EQ.2 .OR. IPERDC.EQ.4 .OR. & IPERDC.EQ.6 .OR. IPERDC.EQ.7) IPERDY = 1 IF (IPERDC.EQ.3 .OR. IPERDC.EQ.5 .OR. & IPERDC.EQ.6 .OR. IPERDC.EQ.7) IPERDZ = 1 LUN = LFUNS CALL TEXT (' ') CALL TEXT (' ') CALL TEXT & ('subroutine gb8z(gd8z,ifac8z,i8z,j8z,p1,p2,p3,t,uu8z)') CALL PREC WRITE (LUN,90) NEQNMX CALL TEXT ('dimension uu8z(10,neqnmx)') CALL COM (2, ' un8z(1,I),un8z(2,I),... hold'// & ' the (rarely used) values') CALL COM (2, ' of UI,UI1,... from the previous'// & ' iteration or time step') IF (DP) THEN CALL TEXT ('common /dtdp5x/ un8z(10,neqnmx)') CALL TEXT ('common /dtdp18/norm1,norm2,norm3') CALL TEXT & ('double precision none,norm1,norm2,norm3,normx,normy,normz') WRITE (LUN,555) (PARNM(I),I=1,NPARN) CALL TEXT ('none = dtdplx(2)') ELSE CALL TEXT ('common / tdp5x/ un8z(10,neqnmx)') CALL TEXT ('common / tdp18/norm1,norm2,norm3') CALL TEXT & ('real none,norm1,norm2,norm3,normx,normy,normz') WRITE (LUN,555) (PARNM(I),I=1,NPARN) CALL TEXT ('none = tdplx(2)') ENDIF DO 300 IEQ = 1,NEQN WRITE (LUN,100) UNK(IEQ)(1:NUNK(IEQ)),IEQ WRITE (LUN,110) UNK(IEQ)(1:NUNK(IEQ)),IEQ WRITE (LUN,120) UNK(IEQ)(1:NUNK(IEQ)),IEQ WRITE (LUN,130) UNK(IEQ)(1:NUNK(IEQ)),IEQ 300 CONTINUE IF (DP) THEN CALL TEXT ('call dtdpcd(p1,p2,p3)') CALL TEXT ('call dtdpcb(p1,p2,p3,norm1,norm2,norm3,'// & 'x,y,z,normx,normy,normz,3)') ELSE CALL TEXT ('call tdpcd(p1,p2,p3)') CALL TEXT ('call tdpcb(p1,p2,p3,norm1,norm2,norm3,'// & 'x,y,z,normx,normy,normz,3)') ENDIF DO 305 IEQ=1,NEQN IF (DP) THEN CALL TEXT ('call dtdpcb(') ELSE CALL TEXT ('call tdpcb(') ENDIF NK = NUNK(IEQ) WRITE (LUN,304) UNK(IEQ)(1:NK),UNK(IEQ)(1:NK), & UNK(IEQ)(1:NK),UNK(IEQ)(1:NK),UNK(IEQ)(1:NK), & UNK(IEQ)(1:NK) 304 FORMAT (5X,'& p1,p2,p3,',A,'1,',A,'2,',A,'3,', & 'x,y,z,',A,'x,',A,'y,',A,'z,2)') WRITE (LUN,234) UNK(IEQ)(1:NK),UNK(IEQ)(1:NK), & UNK(IEQ)(1:NK),UNK(IEQ)(1:NK) 305 CONTINUE CALL TEXT ('if (j8z.eq.0) gd8z = 0.0') CALL MESS (0,369 + IND) DO 360 IFACE = 1,6 WRITE (LUN,310) IFACE 310 FORMAT (12X,'if (ifac8z.eq.',I2,') then') CALL MESS (0,313 + IFACE - 1) IF (IFACE.EQ.1 .OR. IFACE.EQ.2) THEN IPER = IPERDX NGRID = NP1GRID ELSE IF (IFACE.EQ.3 .OR. IFACE.EQ.4) THEN IPER = IPERDY NGRID = NP2GRID ELSE IPER = IPERDZ NGRID = NP3GRID ENDIF IF (IPER.EQ.0 .AND. NGRID.GT.1) THEN CALL IADD (3,'the boundary conditions (on this face only)') CALL TEXT (' if (j8z.eq.0) then') IDEF = 0 ELSE IF (IPER.EQ.1) THEN WRITE (INTOUT,320) IPERDC 320 FORMAT (/,' IPERDC = ',I1, & ', so periodic boundary conditions set automatically') CALL PAWS CALL TEXT (' if (j8z.eq.0) then') CALL COM (2, & ' PERIODIC BOUNDARY CONDITIONS SET (SEE IPERDC)') IDEF = 3 ELSE WRITE (INTOUT,325) 325 FORMAT (/,' No boundary conditions required on this face') CALL PAWS CALL TEXT (' if (j8z.eq.0) then') CALL COM (2, & ' NO BOUNDARY CONDITIONS REQUIRED ON THIS FACE') IDEF = 3 ENDIF DO 330 I = 1,NEQN IF (IDEF.EQ.0) CALL GUI() CALL VECFUN ('G',I,NEQN,I,'gd8z',IDEF,'i8z') 330 CONTINUE CALL TEXT (' else') IF (.NOT.LINEAR .AND. .NOT.FDIFF) THEN DO 350 I = 1,NEQN DO 340 J = 1,NEQN JJ = 10*(J-1) CALL MATFUN('G', I, NEQN, UNK(J)(1:NUNK(J)), & I, JJ+1, 'gd8z', IDEF) CALL MATFUN('G', I, NEQN, UNK(J)(1:NUNK(J))//'x', & I, JJ+2, 'gd8z', IDEF) CALL MATFUN('G', I, NEQN, UNK(J)(1:NUNK(J))//'y', & I, JJ+3, 'gd8z', IDEF) CALL MATFUN('G', I, NEQN, UNK(J)(1:NUNK(J))//'z', & I, JJ+4, 'gd8z', IDEF) 340 CONTINUE 350 CONTINUE ENDIF CALL TEXT (' endif') CALL TEXT (' endif') 360 CONTINUE C CALL TEXT ('return') CALL TEXT ('end') C OUTPUT MODIFICATION FUNCTIONS DEFINED LUN = LFUNS CALL TEXT (' ') CALL TEXT (' ') CALL TEXT ('subroutine pmod8z(p1,p2,p3,t,uu8z,uprint,uxprint,'// & 'uyprint,uzprint)') CALL PREC CALL TEXT ('dimension uu8z(10,*),uprint(*),uxprint(*),'// & 'uyprint(*),uzprint(*)') IF (DP) THEN CALL TEXT & ('common/dtdp14/sint(20),bint(20),slim8z(20),blim8z(20)') ELSE CALL TEXT & ('common/ tdp14/sint(20),bint(20),slim8z(20),blim8z(20)') ENDIF WRITE (LUN,555) (PARNM(I),I=1,NPARN) DO 370 IEQ = 1,NEQN WRITE (LUN,100) UNK(IEQ)(1:NUNK(IEQ)),IEQ WRITE (LUN,110) UNK(IEQ)(1:NUNK(IEQ)),IEQ WRITE (LUN,120) UNK(IEQ)(1:NUNK(IEQ)),IEQ WRITE (LUN,130) UNK(IEQ)(1:NUNK(IEQ)),IEQ WRITE (LUN,140) UNK(IEQ)(1:NUNK(IEQ)),IEQ WRITE (LUN,150) UNK(IEQ)(1:NUNK(IEQ)),IEQ WRITE (LUN,160) UNK(IEQ)(1:NUNK(IEQ)),IEQ WRITE (LUN,170) UNK(IEQ)(1:NUNK(IEQ)),IEQ WRITE (LUN,180) UNK(IEQ)(1:NUNK(IEQ)),IEQ WRITE (LUN,190) UNK(IEQ)(1:NUNK(IEQ)),IEQ WRITE (LUN,200) UNK(IEQ)(1:NUNK(IEQ)),IEQ WRITE (LUN,210) UNK(IEQ)(1:NUNK(IEQ)),IEQ WRITE (LUN,220) UNK(IEQ)(1:NUNK(IEQ)),IEQ 370 CONTINUE IF (DP) THEN CALL TEXT ('call dtdpcd(p1,p2,p3)') ELSE CALL TEXT ('call tdpcd(p1,p2,p3)') ENDIF DO 375 IEQ=1,NEQN IF (DP) THEN CALL TEXT ('call dtdpcc(p1,p2,p3,') ELSE CALL TEXT ('call tdpcc(p1,p2,p3,') ENDIF NK = NUNK(IEQ) WRITE (LUN,371) UNK(IEQ)(1:NK),UNK(IEQ)(1:NK), & UNK(IEQ)(1:NK),UNK(IEQ)(1:NK),UNK(IEQ)(1:NK), & UNK(IEQ)(1:NK),UNK(IEQ)(1:NK),UNK(IEQ)(1:NK), & UNK(IEQ)(1:NK),UNK(IEQ)(1:NK),UNK(IEQ)(1:NK), & UNK(IEQ)(1:NK),UNK(IEQ)(1:NK),UNK(IEQ)(1:NK), & UNK(IEQ)(1:NK),UNK(IEQ)(1:NK),UNK(IEQ)(1:NK), & UNK(IEQ)(1:NK),UNK(IEQ)(1:NK),UNK(IEQ)(1:NK), & UNK(IEQ)(1:NK) 371 FORMAT (5X,'& ',A,'1,',A,'2,',A,'3,',A,'11,', &A,'22,',A,'33,',A,'12,',A,'13,',A,'23,',/,5X,'& x,y,z,', &A,'x,',A,'y,',A,'z,',A,'xx,',A,'yy,',A,'zz,',A,'xy,' &,A,'xz,',A,'yz,',/,5X,'& ',A,'yx,',A,'zx,',A,'zy,dvol8z,dare8z)') WRITE (LUN,372) IEQ,UNK(IEQ)(1:NK),IEQ,UNK(IEQ)(1:NK), & IEQ,UNK(IEQ)(1:NK) 372 FORMAT (6X,'uxprint(',i2,') = ',A,'x',/, & 6X,'uyprint(',i2,') = ',A,'y',/, & 6X,'uzprint(',i2,') = ',A,'z') 375 CONTINUE CALL MESS (0,373 + IND) CALL IADD (3,'these variables') CALL COM (2, ' DEFINE UPRINT(*),UXPRINT(*),'// & 'UYPRINT(*),UZPRINT(*) HERE:') DO 400 I=1,NEQN WRITE (INTOUT,380) UNK(I)(1:NUNK(I)) 380 FORMAT (' Replace ',A,' for postprocessing?') CALL INVEC ('UPRINT',I,I,.FALSE.) WRITE (INTOUT,385) UNK(I)(1:NUNK(I)) 385 FORMAT (' Replace ',A,'x for postprocessing?') CALL INVEC ('UXPRINT',I,I,.FALSE.) WRITE (INTOUT,390) UNK(I)(1:NUNK(I)) 390 FORMAT (' Replace ',A,'y for postprocessing?') CALL INVEC ('UYPRINT',I,I,.FALSE.) WRITE (INTOUT,395) UNK(I)(1:NUNK(I)) 395 FORMAT (' Replace ',A,'z for postprocessing?') CALL INVEC ('UZPRINT',I,I,.FALSE.) 400 CONTINUE CALL TEXT ('return') CALL TEXT ('end') C CALCULATE STORAGE REQUIREMENTS LUN = LPARAM CALL COM (2,' DIMENSIONS OF WORK ARRAYS') IRWK = 1 IIWK = 1 CALL COM (2, ' SET TO 1 FOR AUTOMATIC ALLOCATION') WRITE (LUN,410) IRWK,IIWK 410 FORMAT (6X,'PARAMETER (IRWK8Z=',I12,')',/, 6X,'PARAMETER (IIWK8Z=' &,I12,')') CALL TEXT ('PARAMETER (NXP8Z=41,NYP8Z=41,NZP8Z=41,KDEG8Z=1)') C OUTPUT PARAMETERS CALL MESS (0,377) CALL INPARM ('NP1',NP1,1,INF) CALL INPARM ('NP2',NP2,0,INF) IF (NP2.EQ.0) CALL INPARM ('NP3',NP3,0,0) IF (NP2.NE.0) CALL INPARM ('NP3',NP3,1,INF) LUN = LFORT IF (NP2.EQ.0) THEN CALL TEXT ('npts8z = np1+1') CALL MESS (0,378) CALL IADD (0, ' ') ELSE CALL MESS (0,379) CALL COM (2,' defaults for p1a,p1b,p2a,p2b,p3a,p3b') CALL TEXT ('p1a = p1grid(1)') CALL TEXT ('p1b = p1grid(np1grid)') CALL TEXT ('p2a = p2grid(1)') CALL TEXT ('p2b = p2grid(np2grid)') CALL TEXT ('p3a = p3grid(1)') CALL TEXT ('p3b = p3grid(np3grid)') CALL COM (2, & ' DEFINE P1A,P1B,P2A,P2B,P3A,P3B IMMEDIATELY BELOW:') CALL INVAR ('P1A',.FALSE.) CALL INVAR ('P1B',.FALSE.) CALL INVAR ('P2A',.FALSE.) CALL INVAR ('P2B',.FALSE.) CALL INVAR ('P3A',.FALSE.) CALL INVAR ('P3B',.FALSE.) IF (DP) THEN CALL TEXT ('call dtdpx3(np1,np2,np3,p1a,p1b,p2a,p2b,'// & 'p3a,p3b,hp18z,hp28z,hp38z,p1out8z,p2out8z,p3out8z,npts8z)') ELSE CALL TEXT ('call tdpx3(np1,np2,np3,p1a,p1b,p2a,p2b,'// & 'p3a,p3b,hp18z,hp28z,hp38z,p1out8z,p2out8z,p3out8z,npts8z)') ENDIF ENDIF IF (PARA) THEN LUN = LPARAM CALL MESS (0,53) CALL INPARM ('NSAVE', NSAVE, 1, INF) LUN = LFORT ELSE LUN = LPARAM NSAVE = 1 CALL TEXT ('PARAMETER (NSAVE = 1)') LUN = LFORT CALL COM (2, ' SOLUTION SAVED EVERY NOUT ITERATIONS') CALL TEXT ('NOUT = NSTEPS') ENDIF IF (DP) THEN CALL TEXT ('call dtdpqx(np1grid,np2grid,np3grid,'// & 'isolve,neqn,ii8z,ir8z,iperdc)') ELSE CALL TEXT ('call tdpqx(np1grid,np2grid,np3grid,'// & 'isolve,neqn,ii8z,ir8z,iperdc)') ENDIF CALL TEXT ('if (iiwk8z.gt.1) ii8z = iiwk8z') CALL TEXT ('if (irwk8z.gt.1) ir8z = irwk8z') CALL COM (2, ' *******allocate workspace') CALL TEXT ('allocate (iwrk8z(ii8z),rwrk8z(ir8z))') CALL COM (2,' *******DRAW GRID LINES?') CALL TEXT ('PLOT = .TRUE.') CALL COM (2,' *******call pde solver') IF (DP) THEN CALL TEXT ('call dtdp3x(p1grid, p2grid, p3grid, np1grid,'// & ' np2grid, np3grid, neqn, p1out8z, p2out8z, p3out8z, uout,'// & ' tout8z, npts8z, t0, dt, nsteps, nout, nsave, crankn, noupdt,'// & ' itype, linear, isolve, rwrk8z, ir8z, iwrk8z, ii8z,'// & ' iperdc, plot, lsqfit, fdiff, nint, nbint, restrt, gridid)') ELSE CALL TEXT ('call tdp3x(p1grid, p2grid, p3grid, np1grid,'// & ' np2grid, np3grid, neqn, p1out8z, p2out8z, p3out8z, uout,'// & ' tout8z, npts8z, t0, dt, nsteps, nout, nsave, crankn, noupdt,'// & ' itype, linear, isolve, rwrk8z, ir8z, iwrk8z, ii8z,'// & ' iperdc, plot, lsqfit, fdiff, nint, nbint, restrt, gridid)') ENDIF CALL TEXT ('deallocate (iwrk8z,rwrk8z)') IF (EIGEN) THEN CALL COM (2, & ' *******UNCOMMENT TO POSTPROCESS ONLY IF CONVERGED') WRITE (LUN,415) IST999 415 FORMAT ('C',6X,'IF (ITYPE.EQ.3.AND.(.NOT.ECON8Z)) GO TO ',I5) ENDIF IF (ELL.AND.(.NOT.LINEAR)) THEN CALL COM (2, & ' *******UNCOMMENT TO POSTPROCESS ONLY IF CONVERGED') WRITE (LUN,416) IST999 416 FORMAT ('C',6X,'IF (.NOT.NCON8Z) GO TO ',I5) ENDIF IF (DP) THEN CALL COM (2, & ' *******read from restart file to array ures8z') CALL COM (2,' call dtdpr3(1,xres8z,nxp8z,yres8z,nyp8z,'// & 'zres8z,nzp8z,ures8z,neqn)') CALL COM (2, & ' *******write array ures8z back to restart file') CALL COM (2,' call dtdpr3(2,xres8z,nxp8z,yres8z,nyp8z,'// & 'zres8z,nzp8z,ures8z,neqn)') ELSE CALL COM (2, & ' *******read from restart file to array ures8z') CALL COM (2,' call tdpr3(1,xres8z,nxp8z,yres8z,nyp8z,'// & 'zres8z,nzp8z,ures8z,neqn)') CALL COM (2, & ' *******write array ures8z back to restart file') CALL COM (2,' call tdpr3(2,xres8z,nxp8z,yres8z,nyp8z,'// & 'zres8z,nzp8z,ures8z,neqn)') ENDIF CALL COM (2,' *******call user-written postprocessor') CALL TEXT ('call postpr'// & '(tout8z,nsave,p1out8z,p2out8z,p3out8z,np1,np2,np3,uout,neqn,'// & 'p1grid,p2grid,p3grid,np1grid,np2grid,np3grid)') IF (EIGEN) THEN WRITE (LUN,417) IST999 417 FORMAT (6X,'if (itype.eq.4) go to ',I5) ENDIF LUN = LFUNS CALL TEXT (' ') CALL TEXT (' ') CALL TEXT ('function axis8z(i8z,p1,p2,p3,ical8z)') CALL PREC WRITE (LUN,555) (PARNM(I),I=1,NPARN) IF (DP) THEN CALL TEXT ('call dtdpcd(p1,p2,p3)') CALL TEXT ('call dtdpcb(p1,p2,p3,zr18z,zr28z,zr38z,'// & 'x,y,z,d18z,d28z,d38z,1)') ELSE CALL TEXT ('call tdpcd(p1,p2,p3)') CALL TEXT ('call tdpcb(p1,p2,p3,zr18z,zr28z,zr38z,'// & 'x,y,z,d18z,d28z,d38z,1)') ENDIF CALL TEXT ('axis8z = 0.0') ICAL8Z = 0 LUN = LFORT 420 CONTINUE CALL MESS (1,380) IPLIM = 6 IF (NP2.EQ.0) IPLIM = 1 CALL IREAD (' ',IPLOT,0,IPLIM) IF (IPLOT .EQ. 0) THEN GO TO 460 ELSE IF (IPLOT .EQ. 1) THEN C TABLE OF VALUES AT OUTPUT POINTS CALL COM (2,' *******TABULAR OUTPUT') CALL MESS (0,381 + IND) CALL IREAD ('IVAR',IVAR,1,4*NEQN) CALL TEXT ('ivara8z = mod(ivar-1,4)+1') CALL TEXT ('ivarb8z = (ivar-1)/4+1') IF (.NOT.PARA) THEN CALL TEXT ('ISET1 = 1') CALL TEXT ('ISET2 = NSAVE') CALL TEXT ('ISINC = 1') ELSE CALL MESS (0,123) CALL TEXT ('ISET1 = 0') CALL TEXT ('ISET2 = NSAVE') CALL TEXT ('ISINC = 1') CALL INVAR ('ISET1',.FALSE.) CALL INVAR ('ISET2',.FALSE.) CALL INVAR ('ISINC',.FALSE.) ENDIF CALL MESS (0,59) CALL TEXT ('TITLE = '' '' ') CALL INSTR ('TITLE',.FALSE.) CALL STATE (ISTAT) IF (DP) THEN CALL TEXT('call dtdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,610) ISTAT CALL TEXT ('call dtdpdx(p1out8z,p2out8z,p3out8z,'// & 'uout(0,0,0,ivara8z,ivarb8z,is8z),npts8z,title,'// & 'tout8z(is8z))') ELSE CALL TEXT('call tdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,610) ISTAT CALL TEXT ('call tdpdx(p1out8z,p2out8z,p3out8z,'// & 'uout(0,0,0,ivara8z,ivarb8z,is8z),npts8z,title,'// & 'tout8z(is8z))') ENDIF WRITE (LUN,630) ISTAT ELSE IF (IPLOT .EQ. 2) THEN C CONTOUR SURFACE PLOT DONE CALL COM (2,' *******CONTOUR SURFACE PLOT') CALL MESS (0,381 + IND) CALL IREAD ('IVAR',IVAR,1,4*NEQN) CALL TEXT ('ivara8z = mod(ivar-1,4)+1') CALL TEXT ('ivarb8z = (ivar-1)/4+1') IF (.NOT.PARA) THEN CALL TEXT ('ISET1 = 1') CALL TEXT ('ISET2 = NSAVE') CALL TEXT ('ISINC = 1') ELSE CALL MESS (0,123) CALL TEXT ('ISET1 = 0') CALL TEXT ('ISET2 = NSAVE') CALL TEXT ('ISINC = 1') CALL INVAR ('ISET1',.FALSE.) CALL INVAR ('ISET2',.FALSE.) CALL INVAR ('ISINC',.FALSE.) ENDIF CALL MESS (0,127) CALL TEXT ('VLON = 45.0') CALL TEXT ('VLAT = 45.0') CALL INVAR ('VLAT',.FALSE.) CALL INVAR ('VLON',.FALSE.) CALL MESS (0,385) CALL TEXT ('NC = 4') CALL INVAR ('NC',.FALSE.) CALL MESS (0,386) CALL IFYES (YES) IF (YES) THEN CALL TEXT ('SOLID = .TRUE.') ELSE CALL TEXT ('SOLID = .FALSE.') ENDIF CALL COM (2,' ') CALL TEXT ('alow = amin8z(ivar)') CALL TEXT ('ahigh = amax8z(ivar)') CALL MESS (0,387) CALL TEXT ('UMIN = 0.0') CALL TEXT ('UMAX = 0.0') CALL INVAR ('UMIN',.FALSE.) CALL INVAR ('UMAX',.FALSE.) CALL MESS (0,59) CALL TEXT ('TITLE = '' '' ') CALL INSTR ('TITLE',.FALSE.) CALL STATE (ISTAT) IF (DP) THEN CALL TEXT('call dtdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,610) ISTAT CALL TEXT ('call dtdpax('// & 'uout(0,0,0,ivara8z,ivarb8z,is8z),np1,'// & 'np2,np3,p1a,p1b,p2a,p2b,p3a,p3b,vlon,vlat,title,nc,'// & 'umin,umax,solid,tout8z(is8z))') ELSE CALL TEXT('call tdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,610) ISTAT CALL TEXT ('call tdpax('// & 'uout(0,0,0,ivara8z,ivarb8z,is8z),np1,'// & 'np2,np3,p1a,p1b,p2a,p2b,p3a,p3b,vlon,vlat,title,nc,'// & 'umin,umax,solid,tout8z(is8z))') ENDIF WRITE (LUN,630) ISTAT ELSE IF (IPLOT .EQ. 3) THEN C CROSS-SECTION PLOTS CALL COM (2,' *******CROSS-SECTION SURFACE PLOTS') CALL MESS (0,381 + IND) CALL IREAD ('IVAR',IVAR,1,4*NEQN) CALL TEXT ('ivara8z = mod(ivar-1,4)+1') CALL TEXT ('ivarb8z = (ivar-1)/4+1') CALL MESS (1,388) CALL IREAD (' ',ICS,1,3) IF (ICS .EQ. 1) THEN CALL COM (2,' P1 = CONSTANT CROSS-SECTIONS') CALL TEXT ('ics8z = 1') CALL MESS (0,389) CALL GUI() CALL IREAD ('NP1VALS', NP1VALS, 1, 100) CALL INVEC ('P1CROSS', 1, NP1VALS, .TRUE.) ELSE IF (ICS .EQ. 2) THEN CALL COM (2,' P2 = CONSTANT CROSS-SECTIONS') CALL TEXT ('ics8z = 2') CALL MESS (0,390) CALL GUI() CALL IREAD ('NP2VALS', NP2VALS, 1, 100) CALL INVEC ('P2CROSS', 1, NP2VALS, .TRUE.) ELSE IF (ICS .EQ. 3) THEN CALL COM (2,' P3 = CONSTANT CROSS-SECTIONS') CALL TEXT ('ics8z = 3') CALL MESS (0,391) CALL GUI() CALL IREAD ('NP3VALS', NP3VALS, 1, 100) CALL INVEC ('P3CROSS', 1, NP3VALS, .TRUE.) ENDIF IF (.NOT.PARA) THEN CALL TEXT ('ISET1 = 1') CALL TEXT ('ISET2 = NSAVE') CALL TEXT ('ISINC = 1') ELSE CALL MESS (0,123) CALL TEXT ('ISET1 = 0') CALL TEXT ('ISET2 = NSAVE') CALL TEXT ('ISINC = 1') CALL INVAR ('ISET1',.FALSE.) CALL INVAR ('ISET2',.FALSE.) CALL INVAR ('ISINC',.FALSE.) ENDIF CALL MESS (0,127) CALL TEXT ('VLON = 45.0') CALL TEXT ('VLAT = 45.0') CALL INVAR ('VLAT',.FALSE.) CALL INVAR ('VLON',.FALSE.) CALL COM (2,' ') CALL TEXT ('alow = amin8z(ivar)') CALL TEXT ('ahigh = amax8z(ivar)') CALL MESS (0,126) CALL TEXT ('UMIN = 0.0') CALL TEXT ('UMAX = 0.0') CALL INVAR ('UMIN',.FALSE.) CALL INVAR ('UMAX',.FALSE.) CALL MESS (0,59) CALL TEXT ('TITLE = '' '' ') CALL INSTR ('TITLE',.FALSE.) CALL STATE (ISTAT) CALL STATE (ISTAT2) IF (DP) THEN CALL TEXT('call dtdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,610) ISTAT2 IF (ICS .EQ. 1) THEN WRITE (LUN,430) ISTAT CALL TEXT('call dtdpzx(p1cross(ixv8z),p1a,p1b,np1,ix8z)') ELSE IF (ICS .EQ. 2) THEN WRITE (LUN,440) ISTAT CALL TEXT('call dtdpzx(p2cross(jyv8z),p2a,p2b,np2,jy8z)') ELSE IF (ICS .EQ. 3) THEN WRITE (LUN,450) ISTAT CALL TEXT('call dtdpzx(p3cross(kzv8z),p3a,p3b,np3,kz8z)') ENDIF CALL TEXT ('call dtdplo(p1out8z,p2out8z,p3out8z,'// & 'uout(0,0,0,ivara8z,ivarb8z,is8z),np1,np2,np3,ics8z,ix8z,'// & 'jy8z,kz8z,title,vlon,vlat,umin,umax,tout8z(is8z))') ELSE CALL TEXT('call tdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,610) ISTAT2 IF (ICS .EQ. 1) THEN WRITE (LUN,430) ISTAT CALL TEXT('call tdpzx(p1cross(ixv8z),p1a,p1b,np1,ix8z)') ELSE IF (ICS .EQ. 2) THEN WRITE (LUN,440) ISTAT CALL TEXT('call tdpzx(p2cross(jyv8z),p2a,p2b,np2,jy8z)') ELSE IF (ICS .EQ. 3) THEN WRITE (LUN,450) ISTAT CALL TEXT('call tdpzx(p3cross(kzv8z),p3a,p3b,np3,kz8z)') ENDIF CALL TEXT ('call tdplo(p1out8z,p2out8z,p3out8z,'// & 'uout(0,0,0,ivara8z,ivarb8z,is8z),np1,np2,np3,ics8z,ix8z,'// & 'jy8z,kz8z,title,vlon,vlat,umin,umax,tout8z(is8z))') ENDIF WRITE (LUN,630) ISTAT WRITE (LUN,630) ISTAT2 ELSE IF (IPLOT .EQ. 4) THEN C CROSS-SECTION PLOTS CALL COM (2,' *******CROSS-SECTION CONTOUR PLOTS') CALL MESS (0,381 + IND) CALL IREAD ('IVAR',IVAR,1,4*NEQN) CALL TEXT ('ivara8z = mod(ivar-1,4)+1') CALL TEXT ('ivarb8z = (ivar-1)/4+1') CALL MESS (1,388) CALL IREAD (' ',ICS,1,3) IF (ICS .EQ. 1) THEN CALL COM (2,' P1 = CONSTANT CROSS-SECTIONS') CALL TEXT ('ics8z = 1') CALL MESS (0,389) CALL GUI() CALL IREAD ('NP1VALS', NP1VALS, 1, 100) CALL INVEC ('P1CROSS', 1, NP1VALS, .TRUE.) CALL MESS (0,392) CALL IREAD ('ITPLOT', ITPLOT, -1, 2) ELSE IF (ICS .EQ. 2) THEN CALL COM (2,' P2 = CONSTANT CROSS-SECTIONS') CALL TEXT ('ics8z = 2') CALL MESS (0,390) CALL GUI() CALL IREAD ('NP2VALS', NP2VALS, 1, 100) CALL INVEC ('P2CROSS', 1, NP2VALS, .TRUE.) CALL MESS (0,393) CALL IREAD ('ITPLOT', ITPLOT, -1, 2) ELSE IF (ICS .EQ. 3) THEN CALL COM (2,' P3 = CONSTANT CROSS-SECTIONS') CALL TEXT ('ics8z = 3') CALL MESS (0,391) CALL GUI() CALL IREAD ('NP3VALS', NP3VALS, 1, 100) CALL INVEC ('P3CROSS', 1, NP3VALS, .TRUE.) CALL MESS (0,394) CALL IREAD ('ITPLOT', ITPLOT, -1, 2) ENDIF ICAL8Z = ICAL8Z+1 WRITE (LUN,428) ICAL8Z IF (ITPLOT.EQ.2) THEN LUN = LFUNS WRITE (LUN,429) ICAL8Z IF (ICS.EQ.1) THEN CALL MESS (0,395) ELSE IF (ICS.EQ.2) THEN CALL MESS (0,396) ELSE IF (ICS.EQ.3) THEN CALL MESS (0,397) ENDIF CALL IADD (3,'A1 and A2') DO 425 I=1,2 CALL GUI() CALL VECFUN ('A',I,2,I,'axis8z',0,'i8z') 425 CONTINUE CALL TEXT (' endif') LUN = LFORT CALL MESS (0,398) CALL TEXT ('A1MIN = 0.0') CALL TEXT ('A1MAX = 0.0') CALL TEXT ('A2MIN = 0.0') CALL TEXT ('A2MAX = 0.0') CALL INVAR ('A1MIN',.FALSE.) CALL INVAR ('A1MAX',.FALSE.) CALL INVAR ('A2MIN',.FALSE.) CALL INVAR ('A2MAX',.FALSE.) ELSE CALL TEXT ('A1MIN = 0.0') CALL TEXT ('A1MAX = 0.0') CALL TEXT ('A2MIN = 0.0') CALL TEXT ('A2MAX = 0.0') ENDIF IF (.NOT.PARA) THEN CALL TEXT ('ISET1 = 1') CALL TEXT ('ISET2 = NSAVE') CALL TEXT ('ISINC = 1') ELSE CALL MESS (0,123) CALL TEXT ('ISET1 = 0') CALL TEXT ('ISET2 = NSAVE') CALL TEXT ('ISINC = 1') CALL INVAR ('ISET1',.FALSE.) CALL INVAR ('ISET2',.FALSE.) CALL INVAR ('ISINC',.FALSE.) ENDIF CALL MESS (0,260) CALL IFYES (YES) IF (YES) THEN CALL TEXT ('NODIST = .TRUE.') ELSE CALL TEXT ('NODIST = .FALSE.') ENDIF CALL COM (2,' ') CALL TEXT ('alow = amin8z(ivar)') CALL TEXT ('ahigh = amax8z(ivar)') CALL MESS (0,261) CALL TEXT ('UMIN = 0.0') CALL TEXT ('UMAX = 0.0') CALL INVAR ('UMIN',.FALSE.) CALL INVAR ('UMAX',.FALSE.) CALL MESS (0,262) CALL IFYES (YES) IF (YES) THEN CALL TEXT ('FILLIN = .TRUE.') ELSE CALL TEXT ('FILLIN = .FALSE.') ENDIF CALL MESS (0,59) CALL TEXT ('TITLE = '' '' ') CALL INSTR ('TITLE',.FALSE.) CALL STATE (ISTAT) CALL STATE (ISTAT2) IF (DP) THEN CALL TEXT('call dtdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,610) ISTAT2 IF (ICS .EQ. 1) THEN WRITE (LUN,430) ISTAT CALL TEXT('call dtdpzx(p1cross(ixv8z),p1a,p1b,np1,ix8z)') ELSE IF (ICS .EQ. 2) THEN WRITE (LUN,440) ISTAT CALL TEXT('call dtdpzx(p2cross(jyv8z),p2a,p2b,np2,jy8z)') ELSE IF (ICS .EQ. 3) THEN WRITE (LUN,450) ISTAT CALL TEXT('call dtdpzx(p3cross(kzv8z),p3a,p3b,np3,kz8z)') ENDIF CALL TEXT ('call dtdpln(uout(0,0,0,ivara8z,ivarb8z,is8z),'// & 'np1,np2,np3,p1a,p1b,p2a,p2b,p3a,p3b,ics8z,ix8z,jy8z,kz8z,' & //'title,umin,umax,nodist,fillin,tout8z(is8z),'// & 'a1min,a1max,a2min,a2max,itplot,ical8z)') ELSE CALL TEXT('call tdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,610) ISTAT2 IF (ICS .EQ. 1) THEN WRITE (LUN,430) ISTAT CALL TEXT('call tdpzx(p1cross(ixv8z),p1a,p1b,np1,ix8z)') ELSE IF (ICS .EQ. 2) THEN WRITE (LUN,440) ISTAT CALL TEXT('call tdpzx(p2cross(jyv8z),p2a,p2b,np2,jy8z)') ELSE IF (ICS .EQ. 3) THEN WRITE (LUN,450) ISTAT CALL TEXT('call tdpzx(p3cross(kzv8z),p3a,p3b,np3,kz8z)') ENDIF CALL TEXT ('call tdpln(uout(0,0,0,ivara8z,ivarb8z,is8z),'// & 'np1,np2,np3,p1a,p1b,p2a,p2b,p3a,p3b,ics8z,ix8z,jy8z,kz8z,' & //'title,umin,umax,nodist,fillin,tout8z(is8z),'// & 'a1min,a1max,a2min,a2max,itplot,ical8z)') ENDIF WRITE (LUN,630) ISTAT WRITE (LUN,630) ISTAT2 ELSE IF (IPLOT .EQ. 5) THEN C CROSS-SECTION PLOTS CALL COM (2,' *******CROSS-SECTION VECTOR PLOTS') CALL MESS (1,388) CALL IREAD (' ',ICS,1,3) IF (ICS .EQ. 1) THEN CALL COM (2,' P1 = CONSTANT CROSS-SECTIONS') CALL TEXT ('ics8z = 1') CALL MESS (0,389) CALL IREAD ('NP1VALS', NP1VALS, 1, 100) CALL INVEC ('P1CROSS', 1, NP1VALS, .TRUE.) CALL MESS (0,392) CALL IREAD ('ITPLOT', ITPLOT, -1, 2) ELSE IF (ICS .EQ. 2) THEN CALL COM (2,' P2 = CONSTANT CROSS-SECTIONS') CALL TEXT ('ics8z = 2') CALL MESS (0,390) CALL IREAD ('NP2VALS', NP2VALS, 1, 100) CALL INVEC ('P2CROSS', 1, NP2VALS, .TRUE.) CALL MESS (0,393) CALL IREAD ('ITPLOT', ITPLOT, -1, 2) ELSE IF (ICS .EQ. 3) THEN CALL COM (2,' P3 = CONSTANT CROSS-SECTIONS') CALL TEXT ('ics8z = 3') CALL MESS (0,391) CALL IREAD ('NP3VALS', NP3VALS, 1, 100) CALL INVEC ('P3CROSS', 1, NP3VALS, .TRUE.) CALL MESS (0,394) CALL IREAD ('ITPLOT', ITPLOT, -1, 2) ENDIF ICAL8Z = ICAL8Z+1 WRITE (LUN,428) ICAL8Z IF (ITPLOT.EQ.2) THEN LUN = LFUNS WRITE (LUN,429) ICAL8Z IF (ICS.EQ.1) THEN CALL MESS (0,395) ELSE IF (ICS.EQ.2) THEN CALL MESS (0,396) ELSE IF (ICS.EQ.3) THEN CALL MESS (0,397) ENDIF CALL IADD (3,'A1 and A2') DO 426 I=1,2 CALL VECFUN ('A',I,2,I,'axis8z',0,'i8z') 426 CONTINUE CALL TEXT (' endif') LUN = LFORT CALL MESS (0,398) CALL TEXT ('A1MIN = 0.0') CALL TEXT ('A1MAX = 0.0') CALL TEXT ('A2MIN = 0.0') CALL TEXT ('A2MAX = 0.0') CALL INVAR ('A1MIN',.FALSE.) CALL INVAR ('A1MAX',.FALSE.) CALL INVAR ('A2MIN',.FALSE.) CALL INVAR ('A2MAX',.FALSE.) ELSE CALL TEXT ('A1MIN = 0.0') CALL TEXT ('A1MAX = 0.0') CALL TEXT ('A2MIN = 0.0') CALL TEXT ('A2MAX = 0.0') ENDIF CALL MESS (0,399 + IND) CALL IREAD ('IVAR1', IVAR1, 1, 4*NEQN) CALL IREAD ('IVAR2', IVAR2, 1, 4*NEQN) CALL IREAD ('IVAR3', IVAR3, 1, 4*NEQN) CALL TEXT ('ivar1a8z = mod(ivar1-1,4)+1') CALL TEXT ('ivar1b8z = (ivar1-1)/4+1') CALL TEXT ('ivar2a8z = mod(ivar2-1,4)+1') CALL TEXT ('ivar2b8z = (ivar2-1)/4+1') CALL TEXT ('ivar3a8z = mod(ivar3-1,4)+1') CALL TEXT ('ivar3b8z = (ivar3-1)/4+1') IF (.NOT.PARA) THEN CALL TEXT ('ISET1 = 1') CALL TEXT ('ISET2 = NSAVE') CALL TEXT ('ISINC = 1') ELSE CALL MESS (0,123) CALL TEXT ('ISET1 = 0') CALL TEXT ('ISET2 = NSAVE') CALL TEXT ('ISINC = 1') CALL INVAR ('ISET1',.FALSE.) CALL INVAR ('ISET2',.FALSE.) CALL INVAR ('ISINC',.FALSE.) ENDIF CALL MESS (0,260) CALL IFYES (YES) IF (YES) THEN CALL TEXT ('NODIST = .TRUE.') ELSE CALL TEXT ('NODIST = .FALSE.') ENDIF CALL COM (2,' ') CALL TEXT & ('a1mag = max(abs(amin8z(ivar1)),abs(amax8z(ivar1)))') CALL TEXT & ('a2mag = max(abs(amin8z(ivar2)),abs(amax8z(ivar2)))') CALL MESS (0,267) CALL TEXT ('VR1MAG = 0.0') CALL TEXT ('VR2MAG = 0.0') CALL INVAR ('VR1MAG', .FALSE.) CALL INVAR ('VR2MAG', .FALSE.) CALL COM (2,' ') CALL TEXT ('a3low = amin8z(ivar3)') CALL TEXT ('a3high = amax8z(ivar3)') CALL MESS (0,403) CALL TEXT ('VR3MIN = 0.0') CALL TEXT ('VR3MAX = 0.0') CALL INVAR ('VR3MIN', .FALSE.) CALL INVAR ('VR3MAX', .FALSE.) CALL MESS (0,59) CALL TEXT ('TITLE = '' '' ') CALL INSTR ('TITLE',.FALSE.) CALL STATE (ISTAT) CALL STATE (ISTAT2) IF (DP) THEN CALL TEXT('call dtdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,610) ISTAT2 IF (ICS .EQ. 1) THEN WRITE (LUN,430) ISTAT CALL TEXT('call dtdpzx(p1cross(ixv8z),p1a,p1b,np1,ix8z)') ELSE IF (ICS .EQ. 2) THEN WRITE (LUN,440) ISTAT CALL TEXT('call dtdpzx(p2cross(jyv8z),p2a,p2b,np2,jy8z)') ELSE IF (ICS .EQ. 3) THEN WRITE (LUN,450) ISTAT CALL TEXT('call dtdpzx(p3cross(kzv8z),p3a,p3b,np3,kz8z)') ENDIF CALL TEXT ('call dtdplq('// & 'uout(0,0,0,ivar1a8z,ivar1b8z,is8z),'// & 'uout(0,0,0,ivar2a8z,ivar2b8z,is8z),'// & 'uout(0,0,0,ivar3a8z,ivar3b8z,is8z),'// & 'np1,np2,np3,p1a,p1b,p2a,p2b,p3a,p3b,ics8z,ix8z,jy8z,kz8z,'// & 'title,vr1mag,vr2mag,vr3min,vr3max,nodist,tout8z(is8z),'// & 'a1min,a1max,a2min,a2max,itplot,ical8z)') ELSE CALL TEXT('call tdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,610) ISTAT2 IF (ICS .EQ. 1) THEN WRITE (LUN,430) ISTAT CALL TEXT('call tdpzx(p1cross(ixv8z),p1a,p1b,np1,ix8z)') ELSE IF (ICS .EQ. 2) THEN WRITE (LUN,440) ISTAT CALL TEXT('call tdpzx(p2cross(jyv8z),p2a,p2b,np2,jy8z)') ELSE IF (ICS .EQ. 3) THEN WRITE (LUN,450) ISTAT CALL TEXT('call tdpzx(p3cross(kzv8z),p3a,p3b,np3,kz8z)') ENDIF CALL TEXT ('call tdplq('// & 'uout(0,0,0,ivar1a8z,ivar1b8z,is8z),'// & 'uout(0,0,0,ivar2a8z,ivar2b8z,is8z),'// & 'uout(0,0,0,ivar3a8z,ivar3b8z,is8z),'// & 'np1,np2,np3,p1a,p1b,p2a,p2b,p3a,p3b,ics8z,ix8z,jy8z,kz8z,'// & 'title,vr1mag,vr2mag,vr3min,vr3max,nodist,tout8z(is8z),'// & 'a1min,a1max,a2min,a2max,itplot,ical8z)') ENDIF WRITE (LUN,630) ISTAT WRITE (LUN,630) ISTAT2 ELSE IF (IPLOT .EQ. 6) THEN C 1D CROSS-SECTION PLOTS CALL COM (2, ' *******1D CROSS-SECTION PLOTS') CALL MESS (0,381 + IND) CALL IREAD ('IVAR', IVAR, 1, 4*NEQN) CALL MESS (1,404) ICSLIM = 4 IF (.NOT.PARA) ICSLIM = 3 CALL IREAD (' ', ICS, 1, ICSLIM) IF (ICS.EQ.1) THEN CALL COM (2, ' P1 IS VARIABLE') CALL TEXT ('ics8z = 1') CALL MESS (0,405) CALL IREAD ('NP2VALS', NP2VALS, 1, 100) CALL INVEC ('P2CROSS', 1, NP2VALS, .TRUE.) CALL IREAD ('NP3VALS', NP3VALS, 1, 100) CALL INVEC ('P3CROSS', 1, NP3VALS, .TRUE.) ELSE IF (ICS.EQ.2) THEN CALL COM (2, ' P2 IS VARIABLE') CALL TEXT ('ics8z = 2') CALL MESS (0,406) CALL IREAD ('NP1VALS', NP1VALS, 1, 100) CALL INVEC ('P1CROSS', 1, NP1VALS, .TRUE.) CALL IREAD ('NP3VALS', NP3VALS, 1, 100) CALL INVEC ('P3CROSS', 1, NP3VALS, .TRUE.) ELSE IF (ICS.EQ.3) THEN CALL COM (2, ' P3 IS VARIABLE') CALL TEXT ('ics8z = 3') CALL MESS (0,407) CALL IREAD ('NP1VALS', NP1VALS, 1, 100) CALL INVEC ('P1CROSS', 1, NP1VALS, .TRUE.) CALL IREAD ('NP2VALS', NP2VALS, 1, 100) CALL INVEC ('P2CROSS', 1, NP2VALS, .TRUE.) ELSE IF (ICS.EQ.4) THEN CALL COM (2, ' T IS VARIABLE') CALL TEXT ('ics8z = 4') CALL MESS (0,408) CALL IREAD ('NP1VALS', NP1VALS, 1, 100) CALL INVEC ('P1CROSS', 1, NP1VALS, .TRUE.) CALL IREAD ('NP2VALS', NP2VALS, 1, 100) CALL INVEC ('P2CROSS', 1, NP2VALS, .TRUE.) CALL IREAD ('NP3VALS', NP3VALS, 1, 100) CALL INVEC ('P3CROSS', 1, NP3VALS, .TRUE.) ENDIF IF (ICS.LE.3) THEN IF (.NOT.PARA) THEN CALL TEXT ('ISET1 = 1') CALL TEXT ('ISET2 = NSAVE') CALL TEXT ('ISINC = 1') ELSE CALL MESS (0,123) CALL TEXT ('ISET1 = 0') CALL TEXT ('ISET2 = NSAVE') CALL TEXT ('ISINC = 1') CALL INVAR ('ISET1',.FALSE.) CALL INVAR ('ISET2',.FALSE.) CALL INVAR ('ISINC',.FALSE.) ENDIF ENDIF CALL COM (2,' ') CALL TEXT ('alow = amin8z(ivar)') CALL TEXT ('ahigh = amax8z(ivar)') CALL MESS (0,126) CALL TEXT ('UMIN = 0.0') CALL TEXT ('UMAX = 0.0') CALL INVAR ('UMIN', .FALSE.) CALL INVAR ('UMAX', .FALSE.) CALL MESS (0,59) CALL TEXT ('TITLE = '' '' ') CALL INSTR ('TITLE',.FALSE.) CALL STATE (ISTAT) CALL STATE (ISTAT2) CALL STATE (ISTAT3) IF (DP) THEN IF (ICS.EQ.1) THEN CALL TEXT('call dtdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,610) ISTAT3 WRITE (LUN,440) ISTAT2 WRITE (LUN,450) ISTAT CALL TEXT('call dtdpzx(p2cross(jyv8z),p2a,p2b,np2,jy8z)') CALL TEXT('call dtdpzx(p3cross(kzv8z),p3a,p3b,np3,kz8z)') ELSE IF (ICS.EQ.2) THEN CALL TEXT('call dtdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,610) ISTAT3 WRITE (LUN,430) ISTAT2 WRITE (LUN,450) ISTAT CALL TEXT('call dtdpzx(p1cross(ixv8z),p1a,p1b,np1,ix8z)') CALL TEXT('call dtdpzx(p3cross(kzv8z),p3a,p3b,np3,kz8z)') ELSE IF (ICS.EQ.3) THEN CALL TEXT('call dtdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,610) ISTAT3 WRITE (LUN,430) ISTAT2 WRITE (LUN,440) ISTAT CALL TEXT('call dtdpzx(p1cross(ixv8z),p1a,p1b,np1,ix8z)') CALL TEXT('call dtdpzx(p2cross(jyv8z),p2a,p2b,np2,jy8z)') ELSE IF (ICS.EQ.4) THEN CALL TEXT ('is8z = 0') WRITE (LUN,430) ISTAT3 WRITE (LUN,440) ISTAT2 WRITE (LUN,450) ISTAT CALL TEXT('call dtdpzx(p1cross(ixv8z),p1a,p1b,np1,ix8z)') CALL TEXT('call dtdpzx(p2cross(jyv8z),p2a,p2b,np2,jy8z)') CALL TEXT('call dtdpzx(p3cross(kzv8z),p3a,p3b,np3,kz8z)') ENDIF CALL TEXT ('call dtdppx(ics8z,ivar,tout8z,nsave,'// & 'p1out8z,p2out8z,p3out8z,np1,np2,np3,uout,neqn,title,'// & 'umin,umax,ix8z,jy8z,kz8z,is8z)') ELSE IF (ICS.EQ.1) THEN CALL TEXT('call tdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,610) ISTAT3 WRITE (LUN,440) ISTAT2 WRITE (LUN,450) ISTAT CALL TEXT('call tdpzx(p2cross(jyv8z),p2a,p2b,np2,jy8z)') CALL TEXT('call tdpzx(p3cross(kzv8z),p3a,p3b,np3,kz8z)') ELSE IF (ICS.EQ.2) THEN CALL TEXT('call tdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,610) ISTAT3 WRITE (LUN,430) ISTAT2 WRITE (LUN,450) ISTAT CALL TEXT('call tdpzx(p1cross(ixv8z),p1a,p1b,np1,ix8z)') CALL TEXT('call tdpzx(p3cross(kzv8z),p3a,p3b,np3,kz8z)') ELSE IF (ICS.EQ.3) THEN CALL TEXT('call tdprx(tout8z,nsave,iset1,iset2,isinc)') WRITE (LUN,610) ISTAT3 WRITE (LUN,430) ISTAT2 WRITE (LUN,440) ISTAT CALL TEXT('call tdpzx(p1cross(ixv8z),p1a,p1b,np1,ix8z)') CALL TEXT('call tdpzx(p2cross(jyv8z),p2a,p2b,np2,jy8z)') ELSE IF (ICS.EQ.4) THEN CALL TEXT ('is8z = 0') WRITE (LUN,430) ISTAT3 WRITE (LUN,440) ISTAT2 WRITE (LUN,450) ISTAT CALL TEXT('call tdpzx(p1cross(ixv8z),p1a,p1b,np1,ix8z)') CALL TEXT('call tdpzx(p2cross(jyv8z),p2a,p2b,np2,jy8z)') CALL TEXT('call tdpzx(p3cross(kzv8z),p3a,p3b,np3,kz8z)') ENDIF CALL TEXT ('call tdppx(ics8z,ivar,tout8z,nsave,'// & 'p1out8z,p2out8z,p3out8z,np1,np2,np3,uout,neqn,title,'// & 'umin,umax,ix8z,jy8z,kz8z,is8z)') ENDIF WRITE (LUN,630) ISTAT WRITE (LUN,630) ISTAT2 WRITE (LUN,630) ISTAT3 ENDIF GO TO 420 428 FORMAT (6X,'ical8z = ',I4) 429 FORMAT (16X,'if (ical8z.eq.',I4,') then') 430 FORMAT (6X,'do ',I5,' ixv8z=1,np1vals') 440 FORMAT (6X,'do ',I5,' jyv8z=1,np2vals') 450 FORMAT (6X,'do ',I5,' kzv8z=1,np3vals') 460 CONTINUE LUN = LFUNS CALL TEXT ('return') CALL TEXT ('end') C ADD DUMMY PDE2D FUNCTIONS CALL COM (2,' dummy routines') CALL TEXT ('subroutine xy8z(i8z,iarc8z,s,x,y,s0,sf)') CALL PREC CALL TEXT ('return') CALL TEXT ('end') CALL TEXT ('subroutine dis8z(x,y,ktri,triden,shape)') CALL PREC CALL TEXT ('return') CALL TEXT ('end') CALL TEXT ('function fb8z(i8z,iarc8z,ktri,s,x,y,t)') CALL PREC CALL TEXT ('fb8z = 0') CALL TEXT ('return') CALL TEXT ('end') C WRITE POSTPR CALL TEXT (' ') CALL TEXT (' ') CALL TEXT ('subroutine '// & 'postpr(tout,nsave,p1out,p2out,p3out,np1,np2,np3,uout,neqn,'// & 'p1grid,p2grid,p3grid,np1grid,np2grid,np3grid)') CALL PREC CALL TEXT & ('dimension p1out(0:np1,0:np2,0:np3),p2out(0:np1,0:np2,0:np3)') CALL TEXT ('dimension p3out(0:np1,0:np2,0:np3),tout(0:nsave)') CALL TEXT ('dimension uout(0:np1,0:np2,0:np3,4,neqn,0:nsave)') CALL TEXT & ('dimension p1grid(np1grid),p2grid(np2grid),p3grid(np3grid)') WRITE (LUN,555) (PARNM(I),I=1,NPARN) IF (DP) THEN CALL TEXT ('common /dtdp27/ itask,npes,icomm') CALL TEXT ('common /dtdp46/ eps8z,cgtl8z,npmx8z,itype,near8z') ELSE CALL TEXT ('common / tdp27/ itask,npes,icomm') CALL TEXT ('common / tdp46/ eps8z,cgtl8z,npmx8z,itype,near8z') ENDIF CALL TEXT ('data lun,lud/0,47/') CALL TEXT ('if (itask.gt.0) return') CALL COM (2,'UOUT(I,J,K,IDER,IEQ,L) = U_IEQ, if IDER=1') CALL COM (2,' Ux_IEQ, if IDER=2') CALL COM (2,' Uy_IEQ, if IDER=3') CALL COM (2,' Uz_IEQ, if IDER=4') CALL COM (2,' (possibly as modified by UPRINT,..)') CALL COM (2, & ' at the point (P1OUT(I,J,K) , P2OUT(I,J,K) , P3OUT(I,J,K))') CALL COM (2,' at time/iteration TOUT(L).') CALL COM (2,' ******* ADD POSTPROCESSING CODE HERE:') CALL COM (2,' IN THE EXAMPLE BELOW, MATLAB PLOTFILES pde2d.m,') CALL COM (2,' pde2d.rdm CREATED (REMOVE C! COMMENTS TO ACTIVATE)') CALL COM (3,' if (lun.eq.0) then') CALL COM (3,' lun = 46') CALL COM (3,' open (lun,file=''pde2d.m'')') CALL COM (3,' open (lud,file=''pde2d.rdm'')') CALL COM (3, & ' write (lun,*) ''fid = fopen(''''pde2d.rdm'''');''') CALL COM (3,' endif') CALL COM (3,' do 78750 l=0,nsave') IF (DP) THEN CALL COM (3,' if (tout(l).ne.dtdplx(2)) nsave0 = l') ELSE CALL COM (3,' if (tout(l).ne. tdplx(2)) nsave0 = l') ENDIF CALL COM (4,'78750 continue') CALL COM (3,' write (lud,78751) nsave0') CALL COM (3,' write (lud,78751) neqn') CALL COM (3,' write (lud,78751) np1grid') CALL COM (3,' write (lud,78751) np2grid') CALL COM (3,' write (lud,78751) np3grid') CALL COM (3,' write (lud,78751) np1') CALL COM (3,' write (lud,78751) np2') CALL COM (3,' write (lud,78751) np3') CALL COM (4,'78751 format (i8)') CALL COM (3,' do 78754 i=1,np1grid') CALL COM (3,' do 78753 j=1,np2grid') CALL COM (3,' do 78752 k=1,np3grid') CALL COM (3,' p1 = p1grid(i)') CALL COM (3,' p2 = p2grid(j)') CALL COM (3,' p3 = p3grid(k)') IF (DP) THEN CALL COM (3,' call dtdpcd(p1,p2,p3)') CALL COM (3,' call dtdpcb(p1,p2,p3,z18z,z28z,z38z,' & //'x,y,z,d18z,d28z,d38z,1)') ELSE CALL COM (3,' call tdpcd(p1,p2,p3)') CALL COM (3,' call tdpcb(p1,p2,p3,z18z,z28z,z38z,' & //'x,y,z,d18z,d28z,d38z,1)') ENDIF CALL COM (3,' write(lud,78764) x,y,z') CALL COM (4,'78752 continue') CALL COM (4,'78753 continue') CALL COM (4,'78754 continue') CALL COM (3,' do 78757 i=0,np1') CALL COM (3,' do 78756 j=0,np2') CALL COM (3,' do 78755 k=0,np3') CALL COM (3,' p1 = p1out(i,j,k)') CALL COM (3,' p2 = p2out(i,j,k)') CALL COM (3,' p3 = p3out(i,j,k)') IF (DP) THEN CALL COM (3,' call dtdpcd(p1,p2,p3)') CALL COM (3,' call dtdpcb(p1,p2,p3,z18z,z28z,z38z,' & //'x,y,z,d18z,d28z,d38z,1)') ELSE CALL COM (3,' call tdpcd(p1,p2,p3)') CALL COM (3,' call tdpcb(p1,p2,p3,z18z,z28z,z38z,' & //'x,y,z,d18z,d28z,d38z,1)') ENDIF CALL COM (3,' write(lud,78764) p1,p2,p3,x,y,z') CALL COM (4,'78755 continue') CALL COM (4,'78756 continue') CALL COM (4,'78757 continue') CALL COM (3,' if (itype.ne.4) then') CALL COM (3,' do 78763 l=0,nsave0') CALL COM (3,' write (lud,78764) tout(l)') CALL COM (3,' do 78762 ieq=1,neqn') CALL COM (3,' do 78761 ider=1,4') CALL COM (3,' do 78760 i=0,np1') CALL COM (3,' do 78759 j=0,np2') CALL COM (3,' do 78758 k=0,np3') CALL COM (3,' write (lud,78764) uout(i,j,k,ider,ieq,l)') CALL COM (4,'78758 continue') CALL COM (4,'78759 continue') CALL COM (4,'78760 continue') CALL COM (4,'78761 continue') CALL COM (4,'78762 continue') CALL COM (4,'78763 continue') CALL COM (4,'78764 format (e16.8)') CALL COM (3,' endif') CALL COM (2,' ******* WRITE pde2d.m ') CALL COM (3,' call mtdp3d(itype,lun)') CALL TEXT ('return') CALL TEXT ('end') C ENTER USER-SUPPLIED FUNCTIONS CALL MESS (1,61) CALL IFYES (YES) IF (YES) CALL IADD (0,' ') C CALL TDPEX/DTDPEX TO INTERPOLATE TABULAR OUTPUT CALL MESS (1,128) CALL IFYES (YES) IF (YES) THEN C 470 CONTINUE CALL MESS (1,409) 480 CONTINUE WRITE (INTOUT,490) 490 FORMAT (' Function name =') CALL READLN (INPT,6,NOMORE) IF (NOMORE) THEN WRITE (INTOUT,510) GO TO 480 ENDIF DO 500 I = 1,40 IF (INPT(1) .EQ. LET2(I)) GO TO 520 500 CONTINUE WRITE (INTOUT,510) 510 FORMAT ('|---- Illegal function name, re-enter in columns 1-6') GO TO 480 520 CONTINUE WRITE (LUN,530) INPT 530 FORMAT (//,6X,'function ',6A1,'(p1,p2,p3)') CALL PREC CALL MESS (0,410) CALL INPARM ('NWORK',NWORK,17,INF) CALL TEXT ('dimension work(nwork)') CALL TEXT ('character*40 fname') IF (DP) THEN CALL TEXT ('data work(1) /0.0d0/') ELSE CALL TEXT ('data work(1) /0.0/') ENDIF CALL MESS (0,278) CALL INSTR ('FNAME',.TRUE.) CALL MESS (0,132) CALL TEXT ('ISET = 1') CALL INVAR ('ISET',.FALSE.) CALL MESS (0,133) CALL IREAD ('KDEG',KDEG,1,3) IF (DP) THEN WRITE (LUN,540) INPT 540 FORMAT & (6X,6A1,' = dtdpex(fname,iset,work,nwork,kdeg,p1,p2,p3)') ELSE WRITE (LUN,550) INPT 550 FORMAT & (6X,6A1,' = tdpex(fname,iset,work,nwork,kdeg,p1,p2,p3)') ENDIF CALL TEXT ('return') CALL TEXT ('end') CALL MESS (1,134) CALL IFYES (YES) IF (YES) GO TO 470 C ENDIF CALL MESS (1,411) LUN = LFORT WRITE (LUN,630) IST999 CALL TEXT ('call endgks') CALL TEXT ('stop') CALL TEXT ('end') LUN = LPARAM WRITE (LUN,555) (PARNM(I),I=1,NPARN) 555 FORMAT (6X,'common/parm8z/ pi',6A7,/,(5X,'&',9A7)) C CONCATENATE PARAMETERS FILE, MAIN PROGRAM, AND SUBPROGRAMS REWIND LFORT 560 CONTINUE READ (LFORT,570,END=580) LINE 570 FORMAT (A79) WRITE (LPARAM,570) LINE GO TO 560 580 CONTINUE REWIND LFUNS 590 CONTINUE READ (LFUNS,570,END=600) LINE WRITE (LPARAM,570) LINE GO TO 590 600 CONTINUE 610 FORMAT (6X,'do ',I5,' is8z=iset1,iset2,isinc') 630 FORMAT (I5,' continue') STOP END SUBROUTINE MESS(IDEF,IMESS) PARAMETER (NEQNMX=99) PARAMETER (NEXMP=15) COMMON /DIRECT/ IACC(1000) COMMON /UNKNWN/ NUNK(NEQNMX),UNK(NEQNMX) C CHARACTER VARIABLES CHARACTER*3 UNK CHARACTER*1 LINE(72),ICHAR,LET(NEXMP) LOGICAL DP,EXLINE,UNCOM COMMON /EXMP/ LEVEL,IEXMP,DP COMMON /LUNITS/ INTIN,INTOUT,LMESS,LUN,LPARAM,LFORT,LFUNS,INFIL & ,IECHO COMMON /PARMS/ LSCREN,ISMX2D,ISMX3D,UNCOM DATA LET & /'A','B','C','D','E','F','G','H','I','J','K','L','M','N','O'/ C READ MESSAGE FILE LIM1 = IACC(IMESS) LIM2 = IACC(IMESS+1) - 1 IF (LIM2 .GE. LIM1) THEN LCNT = 0 IF (IDEF.NE.1) WRITE (LUN,10) 10 FORMAT ('C',78('#')) DO 50 IREC = LIM1,LIM2 READ (LMESS,60,REC=IREC) ILINE,ICHAR,LINE EXLINE = .FALSE. DO 20 L=1,NEXMP IF (ICHAR.EQ.LET(L) .AND. IEXMP.NE.L) GO TO 50 IF (ICHAR.EQ.LET(L)) EXLINE = .TRUE. 20 CONTINUE IF (.NOT.EXLINE) THEN DO 35 J = 1,69 IF (LINE(J).EQ.'$' .AND. LINE(J+1).EQ.'$') THEN READ (LINE(J+2),30) JI 30 FORMAT (I1) IF (NUNK(JI).EQ.1) THEN LINE(J+2) = UNK(JI)(1:1) ELSE IF (NUNK(JI).EQ.2) THEN LINE(J+1) = UNK(JI)(1:1) LINE(J+2) = UNK(JI)(2:2) ELSE LINE(J) = UNK(JI)(1:1) LINE(J+1) = UNK(JI)(2:2) LINE(J+2) = UNK(JI)(3:3) ENDIF ENDIF 35 CONTINUE JC = 0 DO 40 J=1,71 IF (LINE(J) .NE. '$') THEN JC = JC+1 LINE(JC) = LINE(J) ENDIF 40 CONTINUE DO 45 IC=JC+1,71 LINE(IC) = ' ' 45 CONTINUE ENDIF IF (IDEF.NE.2) THEN WRITE (INTOUT,70) LINE LCNT = LCNT+1 ENDIF IF (IDEF.NE.1) WRITE (LUN,80) LINE IF (LCNT .EQ. LSCREN) THEN CALL PAWS LCNT = 0 ENDIF 50 CONTINUE IF (IDEF.NE.1) WRITE (LUN,10) ENDIF 60 FORMAT (I4,A1,72A1) 70 FORMAT (3X,72A1) 80 FORMAT ('C',5X,72A1,'#') RETURN END SUBROUTINE GLOBP(LET1,N1,LET2,N2,FORB,NFORB,PARNM,NPARN) CHARACTER*1 LET1(N1),LET2(N2),INPT(7) CHARACTER*3 FORB(*),INPT3 CHARACTER*6 TINM CHARACTER*7 PARNM(176) COMMON /LUNITS/ INTIN,INTOUT,LMESS,LUN,LPARAM,LFORT,LFUNS,INFIL & ,IECHO LOGICAL NOMORE LUN = LFORT NPARN = 0 10 CONTINUE WRITE (INTOUT,20) 20 FORMAT (' Parameter name = (type blank line to terminate)') CALL READLN (INPT, 7, NOMORE) IF (NOMORE) GO TO 80 IF (INPT(7).NE.' ' .OR. INPT(1).EQ.' ') THEN WRITE (INTOUT,30) GO TO 10 ENDIF 30 FORMAT ('|---- Illegal parameter name, re-enter in columns 1-6') IF (INPT(2).EQ.' ') THEN DO 40 I=1,N1 IF (INPT(1) .EQ. LET1(I)) GO TO 65 40 CONTINUE WRITE (INTOUT,30) GO TO 10 ELSE DO 50 I=1,N2 IF (INPT(1) .EQ. LET2(I)) GO TO 55 50 CONTINUE WRITE (INTOUT,30) GO TO 10 55 INPT3 = INPT(1)//INPT(2)//INPT(3) DO 60 I=1,NFORB IF (INPT3.EQ.FORB(I)) THEN WRITE (INTOUT,30) GO TO 10 ENDIF 60 CONTINUE ENDIF 65 NPARN = NPARN+1 TINM = INPT(1)//INPT(2)//INPT(3)//INPT(4)//INPT(5)//INPT(6) IF (INPT(1).EQ.'I'.OR.INPT(1).EQ.'J'.OR.INPT(1).EQ.'K'.OR. & INPT(1).EQ.'L'.OR.INPT(1).EQ.'M'.OR.INPT(1).EQ.'N'.OR. & INPT(1).EQ.'i'.OR.INPT(1).EQ.'j'.OR.INPT(1).EQ.'k'.OR. & INPT(1).EQ.'l'.OR.INPT(1).EQ.'m'.OR.INPT(1).EQ.'n') THEN WRITE (INTOUT,70) TINM 70 FORMAT (' Note: ',A6,' must be an integer.') CALL COM(2,' Note: '//TINM//' must be an integer.') ENDIF CALL INVAR (TINM,.TRUE.) PARNM(NPARN) = ','//TINM IF (NPARN.EQ.176) THEN WRITE (INTOUT,75) 75 FORMAT (' Limit on number of global parameters reached') GO TO 80 ENDIF GO TO 10 80 RETURN END SUBROUTINE VARNAM(LET1,N1,LET2,N2,FORB,NFORB,NEQN) PARAMETER (NEQNMX=99) LOGICAL NOMORE COMMON /LUNITS/ INTIN,INTOUT,LMESS,LUN,LPARAM,LFORT,LFUNS,INFIL & ,IECHO COMMON /UNKNWN/ NUNK(NEQNMX),UNK(NEQNMX) CHARACTER*1 LET1(N1),LET2(N2),INPT(4) CHARACTER*3 UNK,FORB(*),INPT3 DO 100 IEQ=1,NEQN 10 CONTINUE IF (IEQ .LE. 9) THEN WRITE (INTOUT,20) IEQ 20 FORMAT (' U',I1,' =') ELSE WRITE (INTOUT,30) IEQ 30 FORMAT (' U',I2,' =') ENDIF CALL READLN (INPT,4,NOMORE) IF (INPT(4).NE.' ' .OR. INPT(1).EQ.' ') THEN WRITE (INTOUT,40) GO TO 10 ENDIF 40 FORMAT ('|---- Illegal variable name, re-enter in columns 1-3') IF (INPT(2) .EQ. ' ') THEN INPT(3) = ' ' DO 50 J = 1,N1 IF (INPT(1) .EQ. LET1(J)) GO TO 80 50 CONTINUE WRITE (INTOUT,40) GO TO 10 ELSE DO 60 J = 1,N2 IF (INPT(1) .EQ. LET2(J)) GO TO 65 60 CONTINUE WRITE (INTOUT,40) GO TO 10 65 INPT3 = INPT(1)//INPT(2)//INPT(3) DO 70 I=1,NFORB IF (INPT3.EQ.FORB(I)) THEN WRITE (INTOUT,40) GO TO 10 ENDIF 70 CONTINUE ENDIF 80 CONTINUE NUNK(IEQ) = 3 IF (INPT(3).EQ.' ') NUNK(IEQ) = 2 IF (INPT(2).EQ.' ') NUNK(IEQ) = 1 UNK(IEQ) = INPT(1)//INPT(2)//INPT(3) 100 CONTINUE RETURN END SUBROUTINE PAWS COMMON /LUNITS/ INTIN,INTOUT,LMESS,LUN,LPARAM,LFORT,LFUNS,INFIL & ,IECHO WRITE (INTOUT,10) 10 FORMAT (70X,'[RETURN]') READ (INTIN,*) RETURN END SUBROUTINE IFYES(YES) LOGICAL YES,EMPTY C CHARACTER VARIABLES CHARACTER*1 IANS(3) COMMON /LUNITS/ INTIN,INTOUT,LMESS,LUN,LPARAM,LFORT,LFUNS,INFIL & ,IECHO C INTERACTIVE INPUT OF YES OR NO ANSWER WRITE (INTOUT,10) 10 FORMAT ('|---- Enter yes or no') 20 CONTINUE CALL READLN (IANS, 3, EMPTY) IF (IANS(1).EQ.'y' .OR. IANS(1).EQ.'n') GO TO 40 IF (IANS(1).EQ.'Y' .OR. IANS(1).EQ.'N') GO TO 40 WRITE (INTOUT,30) 30 FORMAT('|---- What? yes or no, starting in first column please.' &) GO TO 20 40 CONTINUE YES = .FALSE. IF (IANS(1).EQ.'y' .OR. IANS(1).EQ.'Y') YES = .TRUE. RETURN END SUBROUTINE IADD(LEVOPT,VARS) LOGICAL NOMORE,YES,DP C CHARACTER VARIABLES CHARACTER*1 LINE(72) CHARACTER*(*) VARS COMMON /LUNITS/ INTIN,INTOUT,LMESS,LUN,LPARAM,LFORT,LFUNS,INFIL & ,IECHO COMMON /EXMP/ LEVEL,IEXMP,DP IF (LEVOPT .NE. 0) THEN IF (LEVEL .LT. LEVOPT) RETURN WRITE (INTOUT,10) VARS 10 FORMAT (/,' Do you want to write a FORTRAN block to define', &' some parameters to be',/,' used in the definition of ',A,'?') CALL IFYES (YES) IF (.NOT.YES) RETURN ENDIF WRITE (INTOUT,20) 20 FORMAT (' Remember to begin FORTRAN statements in column 7',/, &'|-----7-----Input FORTRAN now (type blank line to terminate)', &'-----------|') C INTERACTIVE INPUT OF FORTRAN FUNCTIONS 30 CONTINUE CALL READLN (LINE, 72, NOMORE) IF (NOMORE) RETURN WRITE (LUN,40) LINE 40 FORMAT (72A1) GO TO 30 END SUBROUTINE IREAD(VARIAB,N,LIM1,LIM2) C COMMON /LUNITS/ INTIN,INTOUT,LMESS,LUN,LPARAM,LFORT,LFUNS,INFIL & ,IECHO CHARACTER*37 CTEMP CHARACTER*(*) VARIAB LOGICAL LOWLIM,UPLIM LOWLIM = LIM1 .GT. (-10000) UPLIM = LIM2 .LT. 10000 IF ( .NOT.LOWLIM .AND. .NOT.UPLIM) THEN WRITE (CTEMP,10) 10 FORMAT (37X) ELSE IF ( .NOT.LOWLIM .AND. UPLIM) THEN WRITE (CTEMP,20) LIM2 20 FORMAT ('in$the$range$-INFINITY$to$',I10,1X) ELSE IF (LOWLIM .AND. .NOT.UPLIM) THEN WRITE (CTEMP,30) LIM1 30 FORMAT ('in$the$range$',I10,'$to$+INFINITY',1X) ELSE IF (LOWLIM .AND. UPLIM) THEN WRITE (CTEMP,40) LIM1,LIM2 40 FORMAT ('in$the$range$',I10,'$to$',I10) ENDIF CALL DELBLK (CTEMP, 37) IF (VARIAB .NE. ' ') THEN WRITE (INTOUT,50) VARIAB 50 FORMAT (2X,A,' =') ENDIF WRITE (INTOUT,60) CTEMP 60 FORMAT ('|---- Enter an integer value ',A37) 70 CONTINUE CALL READIN (N, IER) IF (IER .EQ. 0) THEN IF (.NOT.(N.LT.LIM1 .AND. LOWLIM)) THEN IF (.NOT.(N.GT.LIM2 .AND. UPLIM)) THEN IF (VARIAB .NE. ' ') THEN WRITE (LUN,80) VARIAB,N 80 FORMAT (6X,A,' = ',I10) ENDIF RETURN ENDIF ENDIF ENDIF WRITE (INTOUT,90) CTEMP 90 FORMAT ('|---- Illegal input. Re-enter integer ',A37) GO TO 70 END SUBROUTINE READIN(N,IER) LOGICAL EMPTY CHARACTER*1 LINE(72),NUM(0:9) DATA NUM/'0','1','2','3','4','5','6','7','8','9'/ LIM = 72 IER = 0 CALL READLN (LINE, LIM, EMPTY) DO 10 I = LIM,1,-1 LIMI = I IF (LINE(I) .NE. ' ') GO TO 20 10 CONTINUE GO TO 80 20 CONTINUE N = 0 DO 50 J = LIMI,1,-1 LIMJ = J - 1 DO 30 K = 0,9 IF (LINE(J) .EQ. NUM(K)) THEN N = N + K*10**(LIMI-J) GO TO 40 ENDIF 30 CONTINUE IF (LINE(J) .EQ. ' ') THEN GO TO 40 ELSE IF (LINE(J) .EQ. '+') THEN GO TO 60 ELSE IF (LINE(J) .EQ. ('-')) THEN N = -N GO TO 60 ELSE GO TO 80 ENDIF 40 CONTINUE 50 CONTINUE 60 CONTINUE IF (LIMJ .LE. 0) RETURN DO 70 I = LIMJ,1,-1 IF (LINE(I) .NE. ' ') GO TO 80 70 CONTINUE RETURN 80 CONTINUE IER = 1 RETURN END SUBROUTINE DELBLK(CTEMP,N) CHARACTER*(*) CTEMP L = 0 DO 10 I = 1,N IF (CTEMP(I:I) .NE. ' ') THEN L = L + 1 CTEMP(L:L) = CTEMP(I:I) ENDIF 10 CONTINUE DO 20 I = 1,N IF (CTEMP(I:I) .EQ. '$') CTEMP(I:I) = ' ' IF (I .GT. L) CTEMP(I:I) = ' ' 20 CONTINUE RETURN END SUBROUTINE LINUM CHARACTER*73 LINE COMMON /DIRECT/ IACC(1000) COMMON /LUNITS/ INTIN,INTOUT,LMESS,LUN,LPARAM,LFORT,LFUNS,INFIL & ,IECHO C MESSAGE FILES LSEQ = 3 OPEN(LSEQ,FILE='pde2d.seq',STATUS='OLD') LMESS = 4 OPEN(LMESS,ACCESS='DIRECT',RECL=77,STATUS='SCRATCH', & FORM='FORMATTED') C DETERMINE THE BEGINNING RECORD NUMBERS FOR EACH MESSAGE. IOLD = 0 DO 20 IREC = 1,20000 READ (LSEQ,30) ILINE,LINE IF (ILINE .EQ. 9999) GO TO 40 WRITE (LMESS,30,REC=IREC) ILINE,LINE IF (ILINE .NE. IOLD) THEN LIM1 = IOLD + 1 LIM2 = ILINE DO 10 J = LIM1,LIM2 IACC(J) = IREC 10 CONTINUE IOLD = ILINE ENDIF 20 CONTINUE 30 FORMAT (I4,A73) 40 CONTINUE RETURN END SUBROUTINE PREC LOGICAL DP COMMON /EXMP/ LEVEL,IEXMP,DP IF (DP) THEN CALL TEXT ('implicit double precision (a-h,o-z)') ELSE CALL TEXT ('implicit real (a-h,o-z)') ENDIF RETURN END SUBROUTINE INPARM(PARAM,N,LIM1,LIM2) C COMMON /LUNITS/ INTIN,INTOUT,LMESS,LUN,LPARAM,LFORT,LFUNS,INFIL & ,IECHO CHARACTER*(*) PARAM CHARACTER*22 CTEMP WRITE (INTOUT,10) PARAM 10 FORMAT (2X,A,' =') CALL IREAD (' ', N, LIM1, LIM2) WRITE (CTEMP,20) PARAM,N 20 FORMAT ('(',A7,'$=$',I10,')') CALL DELBLK (CTEMP, 22) WRITE (LUN,30) CTEMP 30 FORMAT (6X,'PARAMETER ',A22) RETURN END SUBROUTINE INVAR(VARIAB,REQD) C COMMON /LUNITS/ INTIN,INTOUT,LMESS,LUN,LPARAM,LFORT,LFUNS,INFIL & ,IECHO CHARACTER*(*) VARIAB CHARACTER*1 LINE(65) LOGICAL EMPTY,REQD IF (REQD) THEN WRITE (INTOUT,10) VARIAB 10 FORMAT (2X,A,' =') ELSE WRITE (INTOUT,20) VARIAB 20 FORMAT (2X,A,' = (Press [RETURN] to default)') ENDIF CALL READEX (LINE, REQD, EMPTY) IF (.NOT.EMPTY) THEN WRITE (LUN,30) VARIAB,LINE 30 FORMAT (6X,A,' =',/,5X,'& ',65A1) ENDIF RETURN END SUBROUTINE INVEC(VECTOR,I1,I2,REQD) C COMMON /LUNITS/ INTIN,INTOUT,LMESS,LUN,LPARAM,LFORT,LFUNS,INFIL & ,IECHO CHARACTER*(*) VECTOR CHARACTER*21 CTEMP CHARACTER*1 LINE(65) LOGICAL EMPTY,REQD DO 50 I = I1,I2 WRITE (CTEMP,10) VECTOR,I 10 FORMAT (A7,'(',I10,')$=') CALL DELBLK (CTEMP, 21) IF (REQD) THEN WRITE (INTOUT,20) CTEMP 20 FORMAT (2X,A21) ELSE WRITE (INTOUT,30) CTEMP 30 FORMAT (2X,A21,' (Press [RETURN] to default)') ENDIF CALL READEX (LINE, REQD, EMPTY) IF (.NOT.EMPTY) THEN WRITE (LUN,40) CTEMP,LINE 40 FORMAT (6X,A21,/,5X,'& ',65A1) ENDIF 50 CONTINUE RETURN END SUBROUTINE INMAT(MATRIX,I1,I2,J1,J2,REQD) C COMMON /LUNITS/ INTIN,INTOUT,LMESS,LUN,LPARAM,LFORT,LFUNS,INFIL & ,IECHO CHARACTER*(*) MATRIX CHARACTER*32 CTEMP CHARACTER*1 LINE(65) LOGICAL EMPTY,REQD DO 70 J = J1,J2 IF (I2.GT.I1) THEN CALL SPACER ENDIF DO 60 I = I1,I2 WRITE (CTEMP,20) MATRIX,I,J 20 FORMAT (A7,'(',I10,',',I10,')$=') CALL DELBLK (CTEMP, 32) IF (REQD) THEN WRITE (INTOUT,30) CTEMP 30 FORMAT (2X,A32) ELSE WRITE (INTOUT,40) CTEMP 40 FORMAT (2X,A32,' (Press [RETURN] to default)') ENDIF CALL READEX (LINE, REQD, EMPTY) IF (.NOT.EMPTY) THEN WRITE (LUN,50) CTEMP,LINE 50 FORMAT (6X,A32,/,5X,'& ',65A1) ENDIF 60 CONTINUE 70 CONTINUE RETURN END SUBROUTINE TEXT(CHAR) CHARACTER*(*) CHAR N = LEN(CHAR) CALL TEXT1 (CHAR,N) RETURN END SUBROUTINE TEXT1(CHAR,N) COMMON /LUNITS/ INTIN,INTOUT,LMESS,LUN,LPARAM,LFORT,LFUNS,INFIL & ,IECHO CHARACTER*(*) CHAR WRITE (LUN,10) (CHAR(I:I),I = 1,N) 10 FORMAT (6X,66A1,/,(5X,'&',66A1)) RETURN END SUBROUTINE COM(IBORD,CHAR) CHARACTER*(*) CHAR N = LEN(CHAR) CALL COM1(IBORD,CHAR,N) RETURN END SUBROUTINE COM1(IBORD,CHAR,N) COMMON /LUNITS/ INTIN,INTOUT,LMESS,LUN,LPARAM,LFORT,LFUNS,INFIL & ,IECHO COMMON /PARMS/ LSCREN,ISMX2D,ISMX3D,UNCOM CHARACTER*1 CHAR1(72) CHARACTER*(*) CHAR LOGICAL UNCOM DO 10 I=1,72 CHAR1(I) = ' ' IF (I.LE.N) CHAR1(I) = CHAR(I:I) 10 CONTINUE IF (IBORD.EQ.1) THEN WRITE (LUN,20) CHAR1 20 FORMAT ('C',78('#'),/,'C',5X,72A1,'#',/,'C',78('#')) ELSE IF (IBORD.EQ.2) THEN WRITE (LUN,30) CHAR1 30 FORMAT ('C',5X,72A1) ELSE IF (IBORD.EQ.3) THEN IF (UNCOM) THEN WRITE (LUN,40) CHAR1 40 FORMAT (5X,72A1) ELSE WRITE (LUN,50) CHAR1 50 FORMAT ('C!',5X,72A1) ENDIF ELSE IF (UNCOM) THEN WRITE (LUN,60) CHAR1 60 FORMAT (72A1) ELSE WRITE (LUN,70) CHAR1 70 FORMAT ('C!',72A1) ENDIF ENDIF RETURN END SUBROUTINE GUI() COMMON /LUNITS/ INTIN,INTOUT,LMESS,LUN,LPARAM,LFORT,LFUNS,INFIL & ,IECHO COMMON /IGUI/ IFGUI IF (IFGUI.EQ.1) THEN WRITE (LUN,10) 10 FORMAT ('C',40('-'),'-> INPUT FROM GUI <-',18('-')) ENDIF RETURN END SUBROUTINE READLN (LINE,NLINE,EMPTY) COMMON /LUNITS/ INTIN,INTOUT,LMESS,LUN,LPARAM,LFORT,LFUNS,INFIL & ,IECHO COMMON /IGUI/ IFGUI CHARACTER*1 LINE(NLINE) LOGICAL EMPTY DATA IFFILE/0/ DATA IFOPEN/0/ IF (IFFILE .NE. 0) GO TO 40 C READ FROM TERMINAL 10 CONTINUE IFFILE = 0 DO 20 I = 1,NLINE LINE(I) = ' ' 20 CONTINUE READ (INTIN,30) (LINE(I),I = 1,NLINE) 30 FORMAT (72A1) IF (LINE(1) .NE. '#') GO TO 60 IF (LINE(2) .EQ. '@') IFGUI = 1 C READ FROM pde2d.in 40 CONTINUE IFFILE = 1 IF (IFOPEN.EQ.0) THEN IFOPEN = 1 OPEN (INFIL,FILE='pde2d.in',STATUS='OLD',ERR=10) ENDIF DO 50 I = 1,NLINE LINE(I) = ' ' 50 CONTINUE READ (INFIL,30,END=10,ERR=10) (LINE(I),I = 1,NLINE) IF (LINE(1) .EQ. '#') GO TO 10 WRITE (INTOUT,30) (LINE(I),I = 1,NLINE) 60 CONTINUE EMPTY = .TRUE. DO 70 I = 1,NLINE IF (LINE(I) .NE. ' ') EMPTY = .FALSE. 70 CONTINUE WRITE (IECHO,30) (LINE(I),I = 1,NLINE) RETURN END SUBROUTINE READEX (LINE,REQD,EMPTY) COMMON /LUNITS/ INTIN,INTOUT,LMESS,LUN,LPARAM,LFORT,LFUNS,INFIL & ,IECHO CHARACTER*1 LINE(65) LOGICAL REQD,EMPTY WRITE (INTOUT,10) 10 FORMAT ('|----Enter constant or FORTRAN expression',23('-'),'|') 20 CONTINUE CALL READLN (LINE, 65, EMPTY) IF (.NOT.REQD) RETURN IF (.NOT.EMPTY) RETURN WRITE (INTOUT,30) 30 FORMAT ('|----Illegal blank line. Enter constant or FORTRAN ', &'expression---|') GO TO 20 END SUBROUTINE INSTR(VARIAB,REQD) C COMMON /LUNITS/ INTIN,INTOUT,LMESS,LUN,LPARAM,LFORT,LFUNS,INFIL & ,IECHO CHARACTER*(*) VARIAB CHARACTER*1 LINE(40) LOGICAL EMPTY,REQD IF (REQD) THEN WRITE (INTOUT,10) VARIAB 10 FORMAT (2X,A,' =') ELSE WRITE (INTOUT,20) VARIAB 20 FORMAT (2X,A,' = (Press [RETURN] to default)') ENDIF WRITE (INTOUT,30) 30 FORMAT ('|----Enter title or name',15('-'),'|') 40 CONTINUE CALL READLN (LINE, 40, EMPTY) IF (.NOT.REQD) GO TO 60 IF (.NOT.EMPTY) GO TO 60 WRITE (INTOUT,50) 50 FORMAT ('|----Illegal blank line. Re-enter------|') GO TO 40 60 CONTINUE IF (.NOT.EMPTY) THEN WRITE (LUN,70) VARIAB,LINE 70 FORMAT (6X,A,' = ''',40A1,'''') ENDIF RETURN END SUBROUTINE VECFUN(CI,I,NEQN,II,NAME,IDEF,VARN) CHARACTER*1 LINE(65) CHARACTER*(*) CI,NAME,VARN COMMON /LUNITS/ INTIN,INTOUT,LMESS,LUN,LPARAM,LFORT,LFUNS,INFIL & ,IECHO LOGICAL EMPTY IF (IDEF.EQ.0) THEN IF (NEQN .GT. 1) THEN IF (I.LE.9) THEN WRITE (INTOUT,10) CI,I 10 FORMAT (' ',A,I1,' =') ELSE WRITE (INTOUT,20) CI,I 20 FORMAT (' ',A,I2,' =') ENDIF ELSE WRITE (INTOUT,30) CI 30 FORMAT (' ',A,' =') ENDIF CALL READEX (LINE, .TRUE., EMPTY) ELSE IF (IDEF.EQ.1) THEN IF (NEQN .GT. 1) THEN IF (I.LE.9) THEN WRITE (INTOUT,40) CI,I 40 FORMAT (' ',A,I1, & ' = (Press [RETURN] to default)') ELSE WRITE (INTOUT,50) CI,I 50 FORMAT (' ',A,I2, & ' = (Press [RETURN] to default)') ENDIF ELSE WRITE (INTOUT,60) CI 60 FORMAT (' ',A, ' = (Press [RETURN] to default)') ENDIF CALL READEX (LINE, .FALSE., EMPTY) ELSE IF (IDEF.EQ.2) THEN IF (NEQN .GT. 1) THEN IF (I.LE.9) THEN WRITE (INTOUT,70) CI,I 70 FORMAT (' ',A,I1, & ' = (Press [RETURN] to default to 0)') ELSE WRITE (INTOUT,80) CI,I 80 FORMAT (' ',A,I2, & ' = (Press [RETURN] to default to 0)') ENDIF ELSE WRITE (INTOUT,90) CI 90 FORMAT (' ',A, ' = (Press [RETURN] to default to 0)' & ) ENDIF CALL READEX (LINE, .FALSE., EMPTY) ELSE EMPTY = .TRUE. ENDIF IF (NEQN .GT. 1) THEN IF (I.LE.9) THEN WRITE (LUN,100) CI,I 100 FORMAT ('C',50X,A,I1,' DEFINED') ELSE WRITE (LUN,110) CI,I 110 FORMAT ('C',50X,A,I2,' DEFINED') ENDIF ELSE WRITE (LUN,120) CI 120 FORMAT ('C',50X,A,' DEFINED') ENDIF IF (EMPTY) THEN WRITE (LUN,130) VARN,II,NAME 130 FORMAT ('C if (',A,'.eq.',I5,') ',A,' =', /, & 'C & [DEFAULT SELECTED, DEFINITION COMMENTED OUT]') ELSE WRITE (LUN,140) VARN,II,NAME,LINE 140 FORMAT (' if (',A,'.eq.',I5,') ',A,' =', /,5X,'& ',65A1) ENDIF RETURN END SUBROUTINE MATFUN(CI,I,NEQN,UNKL,II,JJ,NAME,IDEF) CHARACTER*1 LINE(65) CHARACTER*(*) CI,UNKL,NAME COMMON /LUNITS/ INTIN,INTOUT,LMESS,LUN,LPARAM,LFORT,LFUNS,INFIL & ,IECHO LOGICAL EMPTY IF (IDEF.EQ.0) THEN IF (NEQN .GT. 1) THEN IF (I.LE.9) THEN WRITE (INTOUT,10) CI,I,UNKL,CI,I,UNKL 10 FORMAT (' ',A,I1,'.',A,' = ', & '(Press [RETURN] to default, if ',A,I1, & ' is a linear function of ',A,')') ELSE WRITE (INTOUT,20) CI,I,UNKL,CI,I,UNKL 20 FORMAT (' ',A,I2,'.',A,' = ', & '(Press [RETURN] to default, if ',A,I2, & ' is a linear function of ',A,')') ENDIF ELSE WRITE (INTOUT,30) CI,UNKL,CI,UNKL 30 FORMAT (' ',A,'.',A,' = ', & '(Press [RETURN] to default, if ',A, & ' is a linear function of ',A,')') ENDIF CALL READEX (LINE, .FALSE., EMPTY) ELSE EMPTY = .TRUE. ENDIF IF (NEQN .GT. 1) THEN IF (I.LE.9) THEN WRITE (LUN,40) CI,I,UNKL 40 FORMAT ('C',50X,A,I1,'.',A,' DEFINED') ELSE WRITE (LUN,50) CI,I,UNKL 50 FORMAT ('C',50X,A,I2,'.',A,' DEFINED') ENDIF ELSE WRITE (LUN,60) CI,UNKL 60 FORMAT ('C',50X,A,'.',A,' DEFINED') ENDIF IF (EMPTY) THEN WRITE (LUN,70) II,JJ,NAME 70 FORMAT ('C if (i8z.eq.',I5,'.and.j8z.eq.',I5,') ', A,' =', & /,'C & [DEFAULT SELECTED, DEFINITION COMMENTED OUT]') ELSE WRITE (LUN,80) II,JJ,NAME,LINE 80 FORMAT (' if (i8z.eq.',I5,'.and.j8z.eq.',I5,') ', A,' =', & /,5X,'& ',65A1) ENDIF RETURN END SUBROUTINE STATE(ISTAT) DATA IST/78754/ IST = IST + 1 ISTAT = IST RETURN END SUBROUTINE SPACER COMMON /LUNITS/ INTIN,INTOUT,LMESS,LUN,LPARAM,LFORT,LFUNS,INFIL & ,IECHO WRITE (INTOUT,10) 10 FORMAT (/) CALL COM (2,' ') RETURN END