c
C FILE NAME EARWRT.HTM ------------------------------------------ 180608
C***********************************************************************
C This subroutine, which forms part of the PHOENICS Input module,
c SATELLITE, writes to the EARDAT file the information needed to
c launch the PHOENICS solver module, EARTH.
c
c It is executed at the very end of the SATELLITE run, after all
c information supplied by the Q1 and Q2 files, and via the keyboard,
c has been taken in and processed.
c***********************************************************************
c
SUBROUTINE WRDF10(LU)
INCLUDE 'farray'
INCLUDE 'patcmn'
INCLUDE 'spedat'
COMMON /IMAGIC/IFIL(8),IQALIB,IMAGSP
COMMON /LGRND/LG(100)/IGRND/IG(200)/RGRND/RG(200)/CGRND/CG(100)
COMMON /LSG/LSGD(100)/ISG/ISGD(100)/RSG/RSGD(200)/CSG/CSGD(10)
COMMON /SPEDAI/NSPMAX,NSPEDA
CHARACTER*4 CSGD,CG,BUFF*80
LOGICAL LSGD,LG
LOGICAL NEZ
INTEGER II(1000)
INCLUDE 'satear'
C INCLUDE 'satgrd'
INCLUDE 'uspcm2'
COMMON/IBFC/NBFC,LUBF1,LUBF2,KXC,KYC,KZC,I1DOM,I2DOM,
1J1DOM,J2DOM,K1DOM,K2DOM,KZXCY,NI,NJ,NK,NIJ,NIJK,NIM1,
1NJM1,NKM1,NFIXDM,NREC12
COMMON/LBFC/STORSA(13)
common/dbs/dbsat
LOGICAL STORSA,STORWD,PRTBFC,DSTSAV,dbsat
COMMON /LVDEC/ LV32,LVDE
LOGICAL LV32,LVDE
COMMON /IVERSION/ ICURVER,IVEROUT
COMMON /IWARN/ NWARN
CHARACTER*80 LINE(2)
SAVE DSTSAV
DATA DSTSAV/.FALSE./
C.......................................................................
call showit('writing eardat')
IF(STEADY) NTFR1=1
CALL SUB4(N1,NXFR1,N2,NYFR1,N3,NZFR1,N4,NTFR1)
CALL NXYZTF(NXFR1,NX,KXFR)
CALL NXYZTF(NYFR1,NY,KYFR)
CALL NXYZTF(NZFR1,NZ,KZFR)
IF(.NOT.STEADY) CALL NXYZTF(NTFR1,LSTEP,KTFR)
CALL SUB2(K1,KZXCY+1,K2,KZXCY+NZ)
IF(DISTIL) DSTSAV=.TRUE.
IF(DSTSAV) DISTIL=.TRUE.
C.....................................................................
c Determine N, the number of 3D-stored variables
N=0
DO 100 I=1,NPHI
IF(MOD(ISLN(I),2).EQ.0.OR.I.EQ.1.OR.I.EQ.2.OR.
1 I.EQ.9.OR.I.EQ.10) THEN
N=N+1
II(N)=I
ENDIF
100 CONTINUE
C.....................................................................
c Write to logical unit 10 the contents of the logical, integer,
c character and real arrays of satear, namely: LDAT, IDAT, NHDAT and
c RDAT
c
if(dbsat) write(60,*) 'lu in wrdf10 = ',lu
WRITE (LU,FMT=9000,ERR=9999,IOSTAT=IOS) LDAT
if(dbsat) write(60,*) 'lu in wrdf10 = ',lu
WRITE (LU,FMT=9010) IDAT
if(dbsat) write(60,*) 'lu in wrdf10 = ',lu
IF(IVEROUT.GE.362) THEN ! use new format for 3.6.1 and above
WRITE (LU,FMT=9021) (NHDAT(I),I=1,20)
ELSE ! use old format for 3.6 and earlier
WRITE (LU,FMT=9022) NHDAT(1)(1:40),(NHDAT(I)(1:4),I=2,10)
WRITE (LU,FMT=9023) (NHDAT(I)(1:4),I=11,21)
ENDIF
if(dbsat) write(60,*) 'lu in wrdf10 = ',lu
WRITE (LU,FMT=9030) RDAT
c Write T or F, for all NPHI dependent variables, to indicate whether
c or not they are to be stored 3D.
if(dbsat) write(60,*) 'lu in wrdf10 = ',lu
WRITE (LU,FMT=9000) (MOD(ISLN(I),2).EQ.0.OR.I.LE.2.OR.I.EQ.9
1 .OR.I.EQ.10,I=1,NPHI)
c
c For all N of the dependent variables which are to be stored 3D, and
c perhaps solved for, write the variable-specific values which may be
c required.
IF(N.GT.0) THEN
c integers
if(dbsat) write(60,*) 'lu in wrdf10 = ',lu
WRITE (LU,FMT=9010) (ITERMS(II(I)),I=1,N),(LITER(II(I)),I=1,N),
1 (I0PHCV(II(I)),I=1,N),(I0PHCL(II(I)),I=1,N),
1 (ISLN(II(I)),I=1,N), (IPRN(II(I)),I=1,N)
c
c characters
if(dbsat) write(60,*) 'lu in wrdf10 = ',lu
WRITE (LU,FMT=9020) (NAME(II(I)),I=1,N)
c reals
if(dbsat) write(60,*) 'lu in wrdf10 = ',lu
WRITE (LU,FMT=9030) (DTFALS(II(I)),I=1,N),(RESREF(II(I)),I=1,N),
1 (PRNDTL(II(I)),I=1,N),(PRT(II(I)),I=1,N),
1 (ENDIT(II(I)),I=1,N), (VARMIN(II(I)),I=1,N),
1 (VARMAX(II(I)),I=1,N),(FIINIT(II(I)),I=1,N)
if(dbsat) write(60,*) 'lu in wrdf10 = ',lu
IF(.NOT.ONEPHS.OR.ASLP) WRITE (LU,FMT=9030)
1 (PHINT(II(I)),I=1,N), (CINT(II(I)),I=1,N)
if(dbsat) write(60,*) 'lu in wrdf10 = ',lu
IF(DISTIL) WRITE (LU,FMT=9030) (EX(II(I)),I=1,N)
ENDIF
c
c write the logicals, integers, characters and reals concerned with
c debug print-out
if(debug) then
write (lu,fmt=9000) ldeb
write (lu,fmt=9010) ideb
write (lu,fmt=9020) nhdeb
write (lu,fmt=9030) rdeb
if(n.gt.0) write (lu,fmt=9000) (dbgphi(ii(i)),i=1,n)
endif
C.......................................................................
c
c write SPEDAT-related information
NSPVDI=0
ISPVDI=0
ISPEDA=0
301 ISPEDA=ISPEDA+1
IF(ISPEDA.LE.NSPEDA) THEN
IF(SPEDAS(ISPEDA)(1:3).EQ.'VDI') THEN
NSPVDI=NSPVDI+1
ELSEIF(NSPVDI.NE.0) THEN
DO 302 I=ISPEDA,NSPEDA
302 SPEDAS(I-NSPVDI)=SPEDAS(I)
NSPEDA=NSPEDA-NSPVDI
ISPEDA=ISPEDA-NSPVDI
NSPVDI=0
ENDIF
GO TO 301
ENDIF
NSPEDA=NSPEDA-NSPVDI
C.......................................................................
c
c write the non-default contents of the LSGD, ISGD, CSGD and RSGD
c (ie SATELLITE-to-GROUND) arrays
WRITE (LU,FMT=9000) (LSGD(I),I=1,NLSG1),(ISGD(I).NE.0,I=1,NISG1),
1 (CSGD(I).NE.' ',I=1,NCSG1),(NEZ(RSGD(I)),I=1,NRSG1),NSPEDA.NE.0
IF(NISG1.GT.0) THEN
J=0
DO 200 I=1,NISG1
IF(ISGD(I).NE.0) THEN
J=J+1
II(J)=I
ENDIF
200 CONTINUE
IF(J.NE.0) WRITE(LU,FMT=9010) (ISGD(II(I)),I=1,J)
ENDIF
IF(NCSG1.GT.0) THEN
J=0
DO 350 I=1,NCSG1
IF(CSGD(I).NE.' ') THEN
J=J+1
II(J)=I
ENDIF
350 CONTINUE
IF(J.NE.0) WRITE(LU,FMT=9020) (CSGD(II(I)),I=1,J)
ENDIF
IF(NRSG1.GT.0) THEN
J=0
DO 300 I=1,NRSG1
IF(NEZ(RSGD(I))) THEN
J=J+1
II(J)=I
ENDIF
300 CONTINUE
IF(J.NE.0) WRITE(LU,FMT=9030) (RSGD(II(I)),I=1,J)
ENDIF
IF(LSGD(56).AND.IVEROUT.GE.362) THEN
WRITE(LU,FMT=9000) LUSP
WRITE(LU,FMT=9010) IUSP
WRITE(LU,FMT=9030) RUSP
ENDIF
C.......................................................................
c
c write further SPEDAT-related information
IF(NSPEDA.NE.0) THEN
WRITE(LU,'(1X,I6)') NSPEDA
DO 310 I=1,NSPEDA
LL=LENGZZ(SPEDAS(I))
310 WRITE(LU,'(1X,A)') SPEDAS(I)(1:LL)
ENDIF
C.......................................................................
c
c write the non-default contents of the LG, IG, CG and RG
c (ie to-be-used-in-GROUND) arrays
WRITE (LU,FMT=9000) (LG(I),I=1,NLG1),(IG(I).NE.0,I=1,NIG1),
1 (CG(I).NE.' ',I=1,NCG1),(NEZ(RG(I)),I=1,NRG1)
IF(NIG1.GT.0) THEN
J=0
DO 400 I=1,NIG1
IF(IG(I).NE.0) THEN
J=J+1
II(J)=I
ENDIF
400 CONTINUE
IF(J.NE.0) WRITE(LU,FMT=9010) (IG(II(I)),I=1,J)
ENDIF
IF(NCG1.GT.0) THEN
J=0
DO 550 I=1,NCG1
IF(CG(I).NE.' ') THEN
J=J+1
II(J)=I
ENDIF
550 CONTINUE
IF(J.NE.0) WRITE(LU,FMT=9020) (CG(II(I)),I=1,J)
ENDIF
IF(NRG1.GT.0) THEN
J=0
DO 500 I=1,NRG1
IF(NEZ(RG(I))) THEN
J=J+1
II(J)=I
ENDIF
500 CONTINUE
IF(J.NE.0) WRITE(LU,FMT=9030) (RG(II(I)),I=1,J)
ENDIF
C.....................................................................
c
c write all information related to patches used for initial and
c boundary conditions, for sources, etc
IF(NUMPAT.GT.0) THEN
WRITE(LU,FMT=9040) (NAMPAT(I),I=1,NUMPAT)
WRITE(LU,FMT=9070) (NINT(F(I)),I=1,10*NUMPAT)
NCOV=(NPATCV-10*NUMPAT)/4
IF(NCOV.GT.0) THEN
WRITE(LU,FMT=9070) (NINT(F(10*NUMPAT+4*I-3)),I=1,NCOV)
WRITE(LU,FMT=9030) (F(10*NUMPAT+4*I-2),
1 F(10*NUMPAT+4*I-1),I=1,NCOV)
ENDIF
ENDIF
C............................. ........................................
c
c write the x/y/z/tfrac arrays defining the structured grid
WRITE (LU,FMT=9030) (F(KXFR+I),I=1,NXFR1)
WRITE (LU,FMT=9030) (F(KYFR+I),I=1,NYFR1)
WRITE (LU,FMT=9030) (F(KZFR+I),I=1,NZFR1)
IF(.NOT.STEADY .AND. .NOT.PARAB) WRITE (LU,FMT=9030) (F(KTFR+I),
1 I=1,NTFR1)
CALL SUB4(NXFR1,N1,NYFR1,N2,NZFR1,N3,NTFR1,N4)
c
c indicate, for BFCs, whether certain areas are to be stored
IF(BFC) WRITE (LU,FMT=9000) (STORSA(I),I=1,13)
c
c indicate for which z-locations xcycle is true
IF(XCYCLE) THEN
DO 10 K=K1,K2
IF(F(K).GT.0.1) GO TO 11
10 CONTINUE
DO 12 K=K1,K2
F(K)=1.0
12 CONTINUE
11 CONTINUE
WRITE (LU,FMT=9030) (F(K),K=K1,K2)
ENDIF
c...................................................................
IF(IQALIB.EQ.0) THEN
IF(LIBREF.NE.0) THEN
WRITE (BUFF,FMT=9050) IRUNN,LIBREF
CALL PUT_LINE(BUFF,.TRUE.)
ELSE
WRITE (BUFF,FMT=9060) IRUNN
CALL PUT_LINE(BUFF,.TRUE.)
ENDIF
ENDIF
RETURN
9999 LINE(1)='Cannot write to EARDAT'
CALL IOEMZZ(IOS,LINE(2))
NWARN=NWARN+1
IF(LV32) THEN
CALL ERRMSG(LINE,2,222,IACT)
ELSE
CALL PUT_LINE(LINE(1),.FALSE.)
CALL PUT_LINE(LINE(2),.TRUE.)
ENDIF
9000 FORMAT (1X,78L1)
9010 FORMAT (1X,7I10)
9020 FORMAT (1X,19A4)
9021 FORMAT (9(1X,2A48,/),1X,2A48)
9022 FORMAT (1X,A40,9A4)
9023 FORMAT (1X,11A4)
9024 FORMAT (1X,2A48)
9030 FORMAT (1X,1P6E13.6)
9040 FORMAT (1X,9A8)
9050 FORMAT (1X,'EARDAT file written for RUN ',I3,', Library Case=',I3,
1 '.')
9060 FORMAT (1X,'EARDAT file written for RUN ',I3,'.')
9070 FORMAT (1X,10I7)
END
c