C **********************************************************************
C                    S U B R O U T I N E S
C **********************************************************************
C& CLEAR
      SUBROUTINE CLEAR(A,M)
      DIMENSION A(M)
      DO I=1,M
      A(I)=0.
      ENDDO
      RETURN
      END 
C& ZWRI
      SUBROUTINE ZWRI(NTSD,DT,IDAT,FIRST,RESTART)
C ----------------------------------------------------------------------
C     x1.  version   KMAX = LM/2,
C     x2.  version   KMAX = LM  ,     x1 changed to x2
C     x2
C ----------------------------------------------------------------------
      LOGICAL FIRST, RESTART
      PARAMETER (IM=111,JM=221,LM=38,LSM=19)
      PARAMETER (LDA=LM+9,LA=13)      
C
      PARAMETER (
     &  IMJM=IM*JM-JM/2,JMP1=JM+1,JAM=6+2*(JM-10),LB=2*IM+JM-3
     &, LM1=LM-1,LP1=LM+1,L3=LDA+LM+1,L4=LDA+2*LM+1,L7=L4+3
     &, LSCRCH=4*LM+1+LA+1)
      PARAMETER (IMT=2*IM-1)
      PARAMETER (KHL00=1,KHH00=IMJM)
C       
      P A R A M E T E R
     1 (IFM=53,JFM=45)
C      
      PARAMETER (KMAX = LM  ,      KMAX1=KMAX+1)
      PARAMETER (KMIN = LM-KMAX,   KTOP =KMIN+1)
      PARAMETER (IMAX =2*IM-1,     JMAX =JM)
      PARAMETER (IMAXI=IMAX-2,     JMAXI=JMAX-2)
      PARAMETER (IMAXD =IMAXI/2+1, JMAXD =JMAXI/2+1)         
C-----------------------------------------------------------------------
                             C O M M O N /GRIDS/
     1 FMLAT(IFM,JFM),FMLON(IFM,JFM),ALAT(IFM,JFM),ALON(IFM,JFM)
     2,HLAT(IMJM),HLON(IMJM),VLAT(IMJM),VLON(IMJM)
     3,KH1FM(IFM,JFM),KH2FM(IFM,JFM),KV1FM(IFM,JFM),KV2FM(IFM,JFM)
     4,IFMHE(IMJM),JFMHE(IMJM)
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
                             C O M M O N /DYNAM/
     & DY,CPGFV,EN,ENT,R,PT,F4D,F4Q,EF4T
     &,DETA(LM),RDETA(LM),AETA(LM),F4Q2(LM),ETA(LP1),DFL(LP1)
C
     &,EM    (JAM),EMT   (JAM)
C
     &,DX    (IMJM),WPDAR (IMJM),CPGFU (IMJM),CURV  (IMJM),FCP   (IMJM)
     &,FDIV  (IMJM),FAD   (IMJM),F     (IMJM),DDMPU (IMJM),DDMPV (IMJM)
C-----------------------------------------------------------------------

C-----------------------------------------------------------------------
                             C O M M O N /VRBLS/
     & PD(IMJM),RES(IMJM),FIS(IMJM)
C
     &,U(IMJM,LM),V(IMJM,LM),T(IMJM,LM),Q(IMJM,LM)
C----------------------------------------------------------------------- 
C-----------------------------------------------------------------------
                             C O M M O N /MASKS/
     & HBM2  (IMJM),VBM2  (IMJM),VBM3  (IMJM),SM    (IMJM),SICE (IMJM)
C
     &,HTM   (IMJM,LM),VTM   (IMJM,LM)
C-----------------------------------------------------------------------
      COMMON/ETADOT/DEDT(IMJM,LM),DEDT2(IMJM,LM) 
      DIMENSION IDAT(3)
      COMMON/ETATM/ ETADO(IMJM,LM),ETAZ(IMJM,LP1),
     *             ETAKH(IMJM,LM1),ETAKHS(IMJM),
     *             ETAPR(IMJM),ETACPR(IMJM)      
      
      DIMENSION WORK(IMJM)
C-----------------------------------------------------------------------
      RG=1.E0/9.8E0
C
 2001 FORMAT('ZWRI:  TIMESTEP NTSD=',I5,'  FCST TIME=',F8.1)
C
      NTSPH=INT(3600./DT+0.5)
      IHR=NTSD/NTSPH+0.5
      IYR= IDAT(3) - 1900
      IMNTH=IDAT(1)
      IDAY=IDAT(2)
      
CX      NTSPH=30
      NTSPH=60
                  
      CALL DIPREC(6,NTSD)
                  
      IF(MOD(NTSD,NTSPH).NE.0)THEN
        IF(NTSD.NE.2) RETURN           !    Version with first 2               
      ENDIF
      
      WRITE(6,2001) NTSD,(NTSD-1)*DT      
      WRITE(6,*)'   ZWRI: ',IYR,IMNTH,IDAY,IHR     
      NU=6      
      
C/      IF(NTSD.EQ.900)THEN            !    Version without writing 
C/      WRITE(50,*)'END OF FIRST DAY'  !    Version without writing 
C/      WRITE( 6,*)'END OF FIRST DAY'  !    Version without writing
C/      STOP                           !    Version without writing
C/      ENDIF                          !    Version without writing
C      CALL TAPES(NU)
Ci      NUWRI=81
CX      IF(FIRST)THEN
      IF(NTSD.EQ.2)THEN
            
      WRITE(6,*)'NTSD =',NTSD       
      WRITE(6,*)'FIRST=',FIRST,' RESTART=',RESTART
      
C/      RETURN       !    Version without writing      
      
         IF(.NOT.RESTART)THEN
C     |---------------------------------------|
C     |               RUN START               |
C     |---------------------------------------|
      WRITE(6,*)'RUN START'
      NUWRI=81
      WRITE(6,*)'Now NUWRI=',NUWRI
Ci         OPEN(NUWRI,FILE=
Ci     *   '/pesqout/sdg04/igor/Data/dataout/x2.eta_1day.out',
Ci     *   STATUS='UNKNOWN',
Ci     *   FORM='UNFORMATTED')
Ci         WRITE(6,*)
Ci     *   'Open   /pesqout/sdg04/igor/Data/dataout/x2.eta_1day.out'         
C                     123456789 12345      
         WRITE(NUWRI)'START ETA MODEL',IM,JM,LM,NTSD,DT,IDAT,
     *   ETA,AETA,DETA,PT,
     *   KMIN,KTOP,KMAX
     
         DO J=1,IMJM
         WORK(J)=RG*FIS(J)
         ENDDO
C                          '1234567890'
         CALL WRIVAR(NUWRI,'FIS*RG (m)',WORK,IMJM,1)
         CALL WRIVAR(NUWRI,'RES       ',RES,IMJM,1)
         CALL WRIVAR(NUWRI,'HTM       ',HTM(1,KTOP),IMJM,KMAX)
         CALL WRIVAR(NUWRI,'VTM       ',VTM(1,KTOP),IMJM,KMAX)      

         CALL CLEAR(DEDT, IMJM*LM )       
      WRITE(6,*)'Write: Parameters, and FIS*RG (m), RES, HTM, VTM'
                 
         ELSE
C     |---------------------------------------|
C     |               RESTART                 |
C     |---------------------------------------|
C         
C        EMPTY
C
       STOP  'RESTART STOP'
C...         IF(NTSD.LE.900)THEN         
C...         OPEN(NUWRI,FILE=
C...     *   '/pesqout/sdg04/igor/Data/dataout/x2.eta_1day.out',
C...     *   STATUS='OLD',
C...     *   FORM='UNFORMATTED')                     
         ENDIF
                 
      ENDIF
C
C
C
C/      RETURN       !    Version without writing    
C
C
C                       '1234567890'       
      WRITE(NUWRI)      'ETA MODEL ',IM,JM,LM,NTSD,DT,IDAT
      CALL WRIVAR(NUWRI,'PD        ',PD,IMJM,1)
      CALL WRIVAR(NUWRI,'T         ',T(1,KTOP),IMJM,KMAX)
      CALL WRIVAR(NUWRI,'U         ',U(1,KTOP),IMJM,KMAX)
      CALL WRIVAR(NUWRI,'V         ',V(1,KTOP),IMJM,KMAX)
      CALL WRIVAR(NUWRI,'ETADOT    ',ETADO(1,KTOP),IMJM,KMAX) 
      
      CALL WRIVAR(NUWRI,'ZINT      ',ETAZ(1,KTOP),IMJM,KMAX+1)
      CALL WRIVAR(NUWRI,'AKH       ',ETAKH(1,KTOP),IMJM,KMAX)
      CALL WRIVAR(NUWRI,'AKHS      ',ETAKHS,IMJM,1) 
      CALL WRIVAR(NUWRI,'PREC      ',ETAPR,IMJM,1)
      CALL WRIVAR(NUWRI,'ACPREC    ',ETACPR,IMJM,1)                     

      WRITE(6,*)'Write: PSLP, T(KMAX), U(KMAX), V(KMAX); KMAX=',KMAX 
      WRITE(6,*)'Write: ZINT(KMAX), AKH(KMAX)'
      WRITE(6,*)'Write: AKHS, PREC, ACPREC' 

CX      CALL DIPREC(6,NTSD)       
      
      IF(NTSD.EQ.900)THEN
      CLOSE(NUWRI)      
      NUWRI=82
      WRITE(6,*)'Now NUWRI=',NUWRI
Ci         OPEN(NUWRI,FILE=
Ci     *   '/pesqout/sdg04/igor/Data/dataout/x2.eta_2day.out',
Ci     *   STATUS='UNKNOWN',
Ci     *   FORM='UNFORMATTED')
      WRITE(6,*)'FOR NTSD=',NTSD 
      WRITE(6,*)'NEW FILE  ...dataout/x2.eta_2day.out'      
      ENDIF
      
      IF(NTSD.EQ.1800)THEN
      CLOSE(NUWRI)
      NUWRI=83
      WRITE(6,*)'Now NUWRI=',NUWRI      
Ci         OPEN(NUWRI,FILE=
Ci     *   '/pesqout/sdg04/igor/Data/dataout/x2.eta_3day.out',
Ci     *   STATUS='UNKNOWN',
Ci     *   FORM='UNFORMATTED')
      WRITE(6,*)'FOR NTSD=',NTSD 
      WRITE(6,*)'NEW FILE  ...dataout/x2.eta_3day.out'      
      ENDIF      
      
      
      IF(NTSD.EQ.2700)THEN
      CLOSE(NUWRI)
      NUWRI=84
      WRITE(6,*)'Now NUWRI=',NUWRI         
Ci         OPEN(NUWRI,FILE=
Ci     *   '/pesqout/sdg04/igor/Data/dataout/x2.eta_4day.out',
Ci     *   STATUS='UNKNOWN',
Ci     *   FORM='UNFORMATTED')
      WRITE(6,*)'FOR NTSD=',NTSD 
      WRITE(6,*)'NEW FILE  ...dataout/x2.eta_4day.out'      
      ENDIF       
      
      IF(NTSD.EQ.3600)THEN
      CLOSE(NUWRI)
      NUWRI=85
      WRITE(6,*)'Now NUWRI=',NUWRI         
Ci         OPEN(NUWRI,FILE=
Ci     *   '/pesqout/sdg04/igor/Data/dataout/x2.eta_5day.out',
Ci     *   STATUS='UNKNOWN',
Ci     *   FORM='UNFORMATTED')
      WRITE(6,*)'FOR NTSD=',NTSD 
      WRITE(6,*)'NEW FILE  ...dataout/x2.eta_5day.out'      
      ENDIF 
            
      IF(NTSD.EQ.4500)THEN
      CLOSE(NUWRI)
      NUWRI=86
      WRITE(6,*)'Now NUWRI=',NUWRI         
Ci         OPEN(NUWRI,FILE=
Ci     *   '/pesqout/sdg04/igor/Data/dataout/x2.eta_6day.out',
Ci     *   STATUS='UNKNOWN',
Ci     *   FORM='UNFORMATTED')
      WRITE(6,*)'FOR NTSD=',NTSD 
      WRITE(6,*)'NEW FILE  ...dataout/x2.eta_6day.out'      
      ENDIF        
                           
      RETURN
      END
C& DIPREC
      SUBROUTINE DIPREC(NU,NSTEP)
C
C     PRECIPITATION DIAGNOSIS
C      
      PARAMETER (IM=111,JM=221,LM=38,LSM=19)
      PARAMETER (LM1=LM-1,LP1=LM+1)
      PARAMETER (IMJM=IM*JM-JM/2)            
C
                             C O M M O N /MASKS/
     & HBM2  (IMJM),VBM2  (IMJM),VBM3  (IMJM),SM    (IMJM),SICE (IMJM)
C
     &,HTM   (IMJM,LM),VTM   (IMJM,LM)
C-----------------------------------------------------------------------
                             C O M M O N /PVRBLS/
     & Z0    (IMJM),AKMS  (IMJM),AKHS  (IMJM),THS   (IMJM),QS    (IMJM)
     &,UZ0   (IMJM),VZ0   (IMJM),THZ0  (IMJM),QZ0   (IMJM)
     &,RF    (IMJM),TWBS  (IMJM),QWBS  (IMJM)
     &,SNO   (IMJM),WET   (IMJM),CLDEFI(IMJM)
     &,PREC  (IMJM),ACPREC(IMJM),ACCLIQ(IMJM),CUPREC(IMJM)
C
     &,Q2(IMJM,LM)
C
      COMMON/ETATM/ ETADO(IMJM,LM),ETAZ(IMJM,LP1),
     *             ETAKH(IMJM,LM1),ETAKHS(IMJM),
     *             ETAPR(IMJM),ETACPR(IMJM) 
C
      SP=0.
      SAP=0.
      SCP=0.
      HPO=0.
      S2P=0.
      S3P=0.
      DO J=1,IMJM
      HPO=HPO+HBM2(J)
      SP=SP+HBM2(J)*PREC(J)
      SAP=SAP+HBM2(J)*ACPREC(J)
      SCP=SCP+HBM2(J)*CUPREC(J)
      S2P=S2P+HBM2(J)*ETAPR(J)
      S3P=S3P+HBM2(J)*ETACPR(J)
      ENDDO
      IF(HPO.NE.0.)THEN
      SP=SP/HPO
      SAP=SAP/HPO
      SCP=SCP/HPO
      S2P=S2P/HPO
      S3P=S3P/HPO
      ELSE
      SP=-999.
      SAP=-999.
      SCP=-999.
      S2P=-999.
      S3P=-999.    
      ENDIF
      WRITE(NU,*)'    PRECIPITATION DIAGNOSIS'
      WRITE(NU,*)'    STEP=',NSTEP
      WRITE(NU,*)'*/Total   precipitation    =',SP,' m/*'
      WRITE(NU,*)'*/Accumulated precipitation=',SAP,' m/*'
      WRITE(NU,*)'*/Cumulus precipitation    =',SCP,' m/*'
      WRITE(NU,*)'*/Total precipitation from  ETAPR     =',S2P,' m/*'
      WRITE(NU,*)'*/Accumulated precipitation from ETAPR=',S3P,' m/*'   
      RETURN
      END            
C& WRIVAR
      SUBROUTINE WRIVAR(NUWRI,NAME10,VAR,IMJM,LM)
      CHARACTER*10 NAME10
      DIMENSION VAR(IMJM,LM)
      DO K=1,LM
      WRITE(NUWRI)NAME10,IMJM,K,LM,(VAR(I,K),I=1,IMJM)
      ENDDO
      RETURN
      END    
C& INVRY
      SUBROUTINE INVRY(A,M,N)
      DIMENSION A(M,N)
      N2=N/2
      DO1 J=1,N2
      DO1 I=1,M
      R=A(I,J)
      A(I,J)=A(I,N-J+1)
      A(I,N-J+1)=R
1     CONTINUE
      RETURN
      END 
C& INDEXH
      INTEGER FUNCTION INDEXH(I,J,IM)
C
      JE=J
      IF(MOD(JE,2).EQ.0)THEN
      KH0=(2*IM-1)*(JE-2)/2+IM
      ELSE
      KH0=(2*IM-1)*(JE-1)/2
      ENDIF
C
         IF(MOD(JE,2).NE.0)THEN
              IF(MOD(I,2).NE.0)THEN     ! JE IS ODD
              IE=(I+1)/2
              INDEXH=KH0+IE              
              ELSE
              INDEXH=0
              ENDIF
        ELSE
              IF(MOD(I,2).EQ.0)THEN     ! JE IS EVEN
              IE=I/2
              INDEXH=KH0+IE               
              ELSE
              INDEXH=0
              ENDIF
        ENDIF
      RETURN
      END
C& INDEXV
      INTEGER FUNCTION INDEXV(I,J,IM)
C
      JE=J
      IF(MOD(JE,2).EQ.0)THEN
      KH0=(2*IM-1)*(JE-2)/2+IM-1
      ELSE
      KH0=(2*IM-1)*(JE-1)/2
      ENDIF
C
         IF(MOD(JE,2).NE.0)THEN
              IF(MOD(I,2).EQ.0)THEN     ! JE IS ODD
              IE=I/2
              INDEXV=KH0+IE              
              ELSE
              INDEXV=0
              ENDIF
        ELSE
              IF(MOD(I,2).NE.0)THEN     ! JE IS EVEN
              IE=(I+1)/2
              INDEXV=KH0+IE              
              ELSE
              INDEXV=0
              ENDIF
        ENDIF
      RETURN
      END
C& EXTRAC
      SUBROUTINE EXTRAC(A,M,AMEAN,AMIN,AMAX,CON,NCON)
      DIMENSION A(M)
      N=0
      S=0.
      DO J=1,M
      R=A(J)
       IF(R.NE.CON)THEN
       AMN=R
       AMX=R
       I=J
       GOTO10
       ENDIF
      ENDDO
      AMEAN=CON
      AMIN=CON
      AMAX=CON
      RETURN
C
10    CONTINUE
      DO J=1,M
      R=A(J)
       IF(R.NE.CON)THEN
       S=S+R
       N=N+1
         IF(R.GT.AMX)THEN
         AMX=R
         ENDIF
         IF(R.LT.AMN)THEN
         AMN=R
         ENDIF
       ENDIF
       ENDDO
C        
      NCON=M-N
      IF(N.NE.0)THEN
      AMEAN=S/FLOAT(N)
      ELSE
      AMEAN=CON
      ENDIF
      AMIN=AMN
      AMAX=AMX
      RETURN
      END
C& EXTARR
      SUBROUTINE EXTARR(NU,NAME,A,M,KL,CON)
      DIMENSION A(M,KL)
      CHARACTER*(*) NAME
      WRITE(NU,*)' ',NAME,'  Mean   Min   Max  Const  Number'
      DO K=1,KL
      CALL EXTRAC(A(1,K),M,AMEAN,AMIN,AMAX,CON,NCON)      
      WRITE(NU,100)AMEAN,AMIN,AMAX,CON,NCON
      ENDDO
100   FORMAT(1X,4(1X,G11.4),1X,I6)
      RETURN
      END 
C& CHDIM
      SUBROUTINE CHDIM(A,M,CONV)
      DIMENSION A(M)
      DO J=1,M
      A(J)=CONV*A(J)
      ENDDO
      RETURN
      END       
C& TAPES
      SUBROUTINE TAPES(NU)
      LOGICAL L,LA(100)
C
      LA(1)=.TRUE.
      DO I=1,99
      IU=I
      INQUIRE(IU,OPENED=L)
      LA(I+1)=L
      ENDDO
      WRITE(NU,99)
 99   FORMAT(5X,'TAPE TABLE')
      WRITE(NU,100)(I,I=0,9)
100   FORMAT(3X,10I2)
      DO J=1,10
      JJ=J-1
      WRITE(NU,101)JJ,(LA(JJ*10+I),I=1,10)
      ENDDO
101   FORMAT(1X,I1,1X,10(1X,L1))
      WRITE(NU,*)'  '
      RETURN
      END 
C& EXTRAM
      SUBROUTINE EXTRAM(NU,NAME,HA,HM,IMJM,KMAX,HASTA,ICL)
      DIMENSION HA(IMJM,KMAX),HM(IMJM,KMAX),
     *          HASTA(KMAX,4)
      CHARACTER*(*) NAME
      DO K=1,KMAX
      S=0.
      NP=0
      IP=0
      DO J=1,IMJM
      R=HA(J,K)
      
      IF(HM(J,K).NE.0.)THEN
      
      NP=NP+1
      S=S+R
      
      IF(IP.NE.0)THEN
         IF(R.GT.RMX)RMX=R
         IF(R.LT.RMN)RMN=R
      ELSE
         RMX=R
         RMN=R
         IP=1
      ENDIF
      
      ENDIF
      
      ENDDO
      
       IF(NP.NE.0)THEN
      HASTA(K,1)=S/FLOAT(NP)
      HASTA(K,2)=RMN
      HASTA(K,3)=RMX
      HASTA(K,4)=FLOAT(NP)
      ELSE
      HASTA(K,1)=-999.9
      HASTA(K,2)=-999.9
      HASTA(K,3)=-999.9
      HASTA(K,4)=0.      
      ENDIF     
      
      ENDDO
      

      
      IF(ICL.EQ.0)THEN
      RETURN
      ELSE
      WRITE(NU,*)'EXTRAM: name=',NAME
      WRITE(NU,101)'Level','Mean','Min','Max','Points'      
      DO K=1,KMAX
      WRITE(NU,100)K,(HASTA(K,I),I=1,3),INT(HASTA(K,4))      
      ENDDO
      RETURN      
      ENDIF
100   FORMAT(I3,3X,3(G10.4,1X),I6)
101   FORMAT(A5,1X,3A11,1X,A6)
      END           
C      -------------------------------------------
C
C      CALL TMDIAG(1,NTSD,DT,IDAT,PDWORK)
C      WRITE(50,*)'NTSD=',NTSD,' IDAT=',IDAT,' #/'
C
C ................. AUX
C& TMDIAG
      SUBROUTINE TMDIAG(ICL,NTSD,DT,IDAT,WORK)
C
C     ICL             is control parameter: 0/1
C     NTSD            is step number
C     DT              is step value (in sec)
C     IDAT(3)         is date (mm, dd, 19yy)
C     WORK(IMJM)      is work array
C
      PARAMETER (IM=111,JM=221,LM=38,LSM=19)
      PARAMETER (LDA=LM+9,LA=13)      
C
      PARAMETER (
     &  IMJM=IM*JM-JM/2,JMP1=JM+1,JAM=6+2*(JM-10),LB=2*IM+JM-3
     &, LM1=LM-1,LP1=LM+1,L3=LDA+LM+1,L4=LDA+2*LM+1,L7=L4+3
     &, LSCRCH=4*LM+1+LA+1)
      PARAMETER (IMT=2*IM-1)
      PARAMETER (KHL00=1,KHH00=IMJM)
C       
      P A R A M E T E R
     1 (IFM=53,JFM=45)
C      
      PARAMETER (KMAX = LM  ,      KMAX1=KMAX+1)
      PARAMETER (KMIN = LM-KMAX,   KTOP =KMIN+1)
      PARAMETER (IMAX =2*IM-1,     JMAX =JM)
      PARAMETER (IMAXI=IMAX-2,     JMAXI=JMAX-2)
      PARAMETER (IMAXD =IMAXI/2+1, JMAXD =JMAXI/2+1)           

C-----------------------------------------------------------------------
                             C O M M O N /VRBLS/
     & PD(IMJM),RES(IMJM),FIS(IMJM)
C
     &,U(IMJM,LM),V(IMJM,LM),T(IMJM,LM),Q(IMJM,LM)
C----------------------------------------------------------------------- 
C-----------------------------------------------------------------------
                             C O M M O N /MASKS/
     & HBM2  (IMJM),VBM2  (IMJM),VBM3  (IMJM),SM    (IMJM),SICE (IMJM)
C
     &,HTM   (IMJM,LM),VTM   (IMJM,LM)
C-----------------------------------------------------------------------
      COMMON/INNERP/IPN,INP(IMJM),IINP(IMJM),JINP(IMJM)   
      COMMON/ETATM/ ETADO(IMJM,LM), ETAZ(IMJM,LP1),
     *              ETAKH(IMJM,LM1),ETAKHS(IMJM),
     *              ETAPR(IMJM),    ETACPR(IMJM)      
      DIMENSION IDAT(3)      
      DIMENSION WORK(IMJM),AMEAN(LP1),AAMEAN(LP1)
      
      IF(ICL.LT.0.AND.ICL.GT.1)THEN
      WRITE(6,*)'ERROR IN TMDIAG: ICL is wrong. ICL=',ICL
      STOP
      ENDIF
      
      IF(ICL.EQ.0)THEN     ! ====================== THEN 1)
      OPEN(50,FILE='/pesqout/sdg04/igor/Data/dataout/X2ETA.out',
     * STATUS='UNKNOWN')
         IMAR=4
         JMAR=4
      CALL SETMPL(IMAR,JMAR)
      CALL CLEAR(WORK,IMJM)
                     
      ELSE                 ! ====================== ELSE 1)
      NTSPH=INT(3600./DT+0.5)
      IHR=NTSD/NTSPH+0.5
      IYR= IDAT(3) - 1900
      IMNTH=IDAT(1)
      IDAY=IDAT(2)         
      CALL KINE(U,V,VTM,EKIN)
      WRITE(50,*)
     * 'TMDIAG EKIN: NTSD=',NTSD,' EKIN=',EKIN,' (m/s)**2'
      CALL PSTEN(PD,WORK,TENPS)
      WRITE(50,*)
     * 'TMDIAG TENPS: NTSD=',NTSD,' TENPS=',TENPS/DT,
     * ' (H/m**2/s)'
      CALL VERDST(ETADO,LM,HTM,AMEAN,AAMEAN)
      WRITE(50,*)'TMDIAG: ETADOT, NTSD=',NTSD,' #/'
      DO L=1,LM
      WRITE(50,*)L,AMEAN(L),AAMEAN(L)
      ENDDO                                   
      CALL VERDST(ETAKH,LM1,HTM,AMEAN,AAMEAN)
      WRITE(50,*)'TMDIAG: ETAKH, NTSD=',NTSD,' #/'
      DO L=1,LM1
      WRITE(50,*)L,AMEAN(L),AAMEAN(L)
      ENDDO
      WRITE(50,*)LM,0.,0.                             
           
      ENDIF                ! ======================= ENDIF 1)
      RETURN
      END
C& KINE
      SUBROUTINE KINE(U,V,VTM,EKIN)
      PARAMETER (IM=111,JM=221,LM=38,LSM=19)
      PARAMETER (LDA=LM+9,LA=13)      
C
      PARAMETER (
     &  IMJM=IM*JM-JM/2,JMP1=JM+1,JAM=6+2*(JM-10),LB=2*IM+JM-3
     &, LM1=LM-1,LP1=LM+1,L3=LDA+LM+1,L4=LDA+2*LM+1,L7=L4+3
     &, LSCRCH=4*LM+1+LA+1)
      PARAMETER (IMT=2*IM-1)
      PARAMETER (KHL00=1,KHH00=IMJM)
      DIMENSION U(IMJM,LM),V(IMJM,LM),VTM(IMJM,LM)            
      COMMON/INNERP/IPN,INP(IMJM),IINP(IMJM),JINP(IMJM)
      
      EK=0.
      DO L=1,LM
      DO J=1,IPN
      K=INP(J)
      EK=EK+VTM(K,L)*(U(K,L)**2+V(K,L)**2)
      ENDDO
      ENDDO
      EKIN=0.5*EK
      RETURN
      END
C& PSTEN
      SUBROUTINE PSTEN(PS,WORK,TENPS)
      PARAMETER (IM=111,JM=221,LM=38,LSM=19)
      PARAMETER (LDA=LM+9,LA=13)      
C
      PARAMETER (
     &  IMJM=IM*JM-JM/2,JMP1=JM+1,JAM=6+2*(JM-10),LB=2*IM+JM-3
     &, LM1=LM-1,LP1=LM+1,L3=LDA+LM+1,L4=LDA+2*LM+1,L7=L4+3
     &, LSCRCH=4*LM+1+LA+1)      
      COMMON/INNERP/IPN,INP(IMJM),IINP(IMJM),JINP(IMJM)
      DIMENSION PS(IMJM), WORK(IMJM)      

      S=0.
      DO J=1,IPN
      K=INP(J)
      R=ABS(PS(K)-WORK(K))            
      S=S+R
      WORK(K)=PS(K)
      ENDDO
      TENPS=S/FLOAT(IPN)      
      RETURN      
      END      
C& VERDST
      SUBROUTINE VERDST(A,KMAX,HTM,AMEAN,AAMEAN)
      PARAMETER (IM=111,JM=221,LM=38,LSM=19)
      PARAMETER (LDA=LM+9,LA=13)      
C
      PARAMETER (
     &  IMJM=IM*JM-JM/2,JMP1=JM+1,JAM=6+2*(JM-10),LB=2*IM+JM-3
     &, LM1=LM-1,LP1=LM+1,L3=LDA+LM+1,L4=LDA+2*LM+1,L7=L4+3
     &, LSCRCH=4*LM+1+LA+1)      
      DIMENSION A(IMJM,KMAX), HTM(IMJM,KMAX), AMEAN(KMAX),
     * AAMEAN(KMAX)
      COMMON/INNERP/IPN,INP(IMJM),IINP(IMJM),JINP(IMJM)

      DO L=1,KMAX
      S1=0.
      S2=0.
      PN=0.      
      DO J=1,IPN
      K=INP(J)
      PN=PN+HTM(K,L)
      R=HTM(K,L)*A(K,L)
      S1=S1+R
      S2=S2+ABS(R)
      ENDDO
      AMEAN(L)=S1/PN
      AAMEAN(L)=S2/PN      
      ENDDO

      RETURN            
      END
C& SETMPL
      SUBROUTINE SETMPL(IMAR,JMAR)
C
C     Subroutine sets parameters of average tables
C     and inner points
C     IMAR and JMAR are marginal area.
C
C       .........JMAR.........
C       IMAR INNER POINTS IMAR
C       .........JMAR.........
C
C         x----o----x----o----x----o----x----o----x   7
C         |    |    |    |    |    |    |    |    |
C         |    |    |    |    |    |    |    |    |
C         o----x----o----x----o----x----o----x----o   6
C         |    |    |    |    |    |    |    |    |
C         |    |    |    |    |    |    |    |    |
C JNORTH  x----o----X||||O||||X||||O||||X----o----x   5 JE=JM-JMAR
C         |    |    |||||||||||||||||||||    |    | 
C         |    |    |||||||||||||||||||||    |    |    
C         o----x----O||||X||||O||||X||||O----x----o   4
C         |    |    |||||||||||||||||||||    |    |   
C         |    |    |||||||||||||||||||||    |    |    
C JSOUTH  x----o----X||||O||||X||||O||||X----o----x   3 JB=JMAR+1
C         |    |    |    |    |    |    |    |    |
C         |    |    |    |    |    |    |    |    |         
C         o----x----o----x----o----x----o----x----o   2 JMAR
C         |    |    |    |    |    |    |    |    |
C         |    |    |    |    |    |    |    |    |
C         x----o----x----o----x----o----x----o----x   1
C         1    2    3    4    5    6    7    8    9
C         1         2         3         4         5                
C              IMAR        
C                   
C         IMAX=2*IM-1
C       1  Odd      IB=JB               IE=IMAX-IMAR              
C       2  Even     IB=JB+1             IE=IMAX-IMAR-1
C         
C     
      PARAMETER (IM=111,JM=221,LM=38,LSM=19)      
      PARAMETER (IMJM = IM*JM - JM/2)
      PARAMETER (LP1=LM+1)
      PARAMETER (IMAX=2*IM-1  , JMAX=JM)
      PARAMETER (KMAX=LM)
           
      PARAMETER (IOA1=      0,IOA2=      IM,IOA3= 2*IM-1,
     *           IOA4=   IM-1,IOA5=      -1,
     *           IOA6=    -IM,IOA7= -2*IM+1,IOA8=  -IM+1,
     *           IOA9=      1,IOA10=   IM+1,
     *          IOA11=   2*IM,IOA12= 3*IM-1,IOA13=4*IM-2,
     *          IOA14= 3*IM-2,IOA15= 2*IM-2,
     *          IOA16=   IM-2,IOA17=     -2,IOA18= -IM-1,
     *          IOA19=  -2*IM,IOA20=-3*IM+1,
     *          IOA21=-4*IM+2,IOA22=-3*IM+2,IOA23=-2*IM+2,
     *          IOA24=  -IM+2,IOA25=      2)
      
                
      PARAMETER (W1 =0.,     W2=1.,     W3=1./2.,   W4=1./3., W5=1./4.)
      PARAMETER (W6 =1./5.,  W7 =1./6,  W8 =1./7.,  W9 =1./8.)  
      PARAMETER (W10=1./9.)
      PARAMETER (W11=1./10., W12=1./11, W13=1./12., W14=1./13.) 
      PARAMETER (W15=1./14., W16=1./15, W17=1./16., W18=1./17.)
      PARAMETER (W19=1./18., W20=1./19, W21=1./20., W22=1./21.)
      PARAMETER (W23=1./22., W24=1./23, W25=1./24., W26=1./25.)
      
      COMMON/INNERP/IPN,INP(IMJM),IINP(IMJM),JINP(IMJM)      

      COMMON/TAB25A/IOA(25),WET(26),IOAC(16) 
      
      COMMON/INNER2/IPN2,IPN3,INP2(IMJM),IIN2(IMJM),JIN2(IMJM),
     *                        INP3(IMJM)
          
      COMMON/LATBND/NUSN,LSBND(IMAX),LNBND(IMAX),
     *              NUWE,LWBND(JM),  LEBND(JM),
     *              JSOUTH,JNORTH
                           
      DATA IOA/  IOA1, IOA2, IOA3, IOA4, IOA5,
     *           IOA6, IOA7, IOA8, IOA9,IOA10,
     *          IOA11,IOA12,IOA13,IOA14,IOA15,
     *          IOA16,IOA17,IOA18,IOA19,IOA20,
     *          IOA21,IOA22,IOA23,IOA24,IOA25/

      DATA WET/ W1,  W2,  W3,  W4,  W5,  W6, W7,  W8,  W9,  W10,
     *       W11, W12, W13, W14, W15, W16, W17, W18, W19, W20,
     *       W21, W22, W23, W24, W25, W26/
      DATA IOAC/7, 8, 9,10,
     *          6, 1, 2,11,
     *          5, 4, 3,12,
     *         16,15,14,13/ 
C
C     INNER POINT ADDRESSES CALCULATION
C
C      1,...,JMAR, <J for inner points>, JM-JMAR+1, ..., JM
C
C
C      IM2=IM-IMAR        !   IMAR = 2
C      JM2=JM-JMAR        !   JMAR = 2
      
      JB=JMAR+1           !   JB   = 3
      JE=JM-JMAR          !  <--  JM-JMAR
      IPN=0
      DO J=JB,JE
      IF(MOD(J,2).EQ.0)THEN
      IB=JB+1
      IE=IMAX-IMAR-1      ! JE-1  !  <-- IMAX-IMAR-1 (19/11/98)
      ELSE
      IB=JB
      IE=IMAX-IMAR        !   2
      ENDIF
      DO I=IB,IE,2
      IPN=IPN+1
      INP(IPN)=INDEXH(I,J,IM)
      IINP(IPN)=I
      JINP(IPN)=J
      ENDDO  ! I Loop
      ENDDO  ! J Loop
C
      IPN2=0
      IPN3=0
      DO J=JB,JE
      IF(MOD(J,2).EQ.0)THEN
      IB=JB+1
      IE=IMAX-IMAR-1     ! JE-1
      ICL=0
      ELSE
      IB=JB
      IE=IMAX-IMAR       !   2
      ICL=1
      ENDIF
      DO I=IB,IE,2
      IF(ICL.EQ.1)THEN      
      IPN2=IPN2+1
      INP2(IPN2)=INDEXH(I,J,IM)
      IIN2(IPN2)=I
      JIN2(IPN2)=J
      ELSE
      IPN3=IPN3+1
      INP3(IPN3)=INDEXH(I,J,IM)      
      ENDIF
      
      ENDDO  ! I Loop
      ENDDO  ! J Loop
      
      WRITE(6,*)'INNER POINTS TEST'
      WRITE(6,*)'*/IPN=',IPN,' IPN2+IPN3=',IPN2+IPN3,' /*'
      WRITE(6,*)'*/IPN2=',IPN2,' IPN3=',IPN3,' /*' 
C      
C
C     LATERAL BOUNDARY POINTS
C           WITH U,V 
C
C     NORTH AND SOUTH LATERAL BOUNDARIS
C
      NUSN=0
      IB=JB+1
      IE=IMAX-IMAR-1
      DO I=IB,IE,2
      NUSN=NUSN+1
      LSBND(NUSN)=INDEXV(I,JB,IM)
      LNBND(NUSN)=INDEXV(I,JE,IM)
      ENDDO
C
C     WEST AND EAST LATERAL BOUNDARIS
C            
      NUWE=0
      JB1=JB+1
      JE1=JE-1
      IWEST=IMAR+1
      IEAST=IMAX-IMAR      
      DO J=JB1,JE1,2
      NUWE=NUWE+1
      LWBND(NUWE)=INDEXV(IWEST,J,IM)  
      LEBND(NUWE)=INDEXV(IEAST,J,IM) 
      ENDDO
      
      JSOUTH=JB
      JNORTH=JE
                                 
      RETURN                 
      END     
C                           *** *** *** 