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(150)/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