SUBROUTINE INITPOST C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . C SUBPROGRAM: INITPOST INITIALIZE POST FOR RUN C PRGRMMR: RUSS TREADON ORG: W/NP2 DATE: 93-11-10 C C ABSTRACT: THIS ROUTINE INITIALIZES CONSTANTS AND C VARIABLES AT THE START OF AN ETA MODEL OR POST C PROCESSOR RUN. C C THIS ROUTINE ASSUMES THAT INTEGERS AND REALS ARE THE SAME SIZE C . C C PROGRAM HISTORY LOG: C 93-11-10 RUSS TREADON - ADDED DOCBLOC C 98-05-29 BLACK - CONVERSION OF POST CODE FROM 1-D TO 2-D C 99-01 20 TUCCILLO - MPI VERSION C C USAGE: CALL INIT C INPUT ARGUMENT LIST: C NONE C C OUTPUT ARGUMENT LIST: C NONE C C OUTPUT FILES: C NONE C C SUBPROGRAMS CALLED: C UTILITIES: C NONE C LIBRARY: C COMMON - CTLBLK C OUTFIL C LOOPS C MASKS C DYNAMD C PHYS2 C MAPOT1 C VRBLS C PVRBLS C BOCO C GRIDS C ACMCLD C ACMCLH C ACMPRE C ACMRDL C ACMRDS C ACMSFC C INDX C C C ATTRIBUTES: C LANGUAGE: FORTRAN C MACHINE : CRAY C-90 C$$$ C C C INCLUDE/SET PARAMETERS. C INCLUDE "parmeta" INCLUDE "params" INCLUDE "parm.tbl" INCLUDE "parmsoil" include "mpif.h" C C DECLARE VARIABLES. C REAL DUMMY ( IM, JM ) REAL DUMMY_MF ( IM, JM, 15 ) C C NOTE: SOME INTEGER VARIABLES ARE READ INTO DUMMY ( A REAL ). THIS IS OK C AS LONG AS REALS AND INTEGERS ARE THE SAME SIZE. C C ALSO, EXTRACT IS CALLED WITH DUMMY ( A REAL ) EVEN WHEN THE NUMBERS ARE C INTEGERS - THIS IS OK AS LONG AS INTEGERS AND REALS ARE THE SAME SIZE. LOGICAL RUN,RUNB,FIRST,RESTRT,SINGLRST 1, SIGMA,SUBPOST,NEST,HYDRO LOGICAL IOOMG,IOALL CHARACTER*32 LABEL CHARACTER*40 CONTRL,FILALL,FILMST,FILTMP,FILTKE,FILUNV &, FILCLD,FILRAD,FILSFC CHARACTER*4 RESTHR C JLG increased lenght of FNAME CHARACTER FNAME*256,ENVAR*50,BLANK*4 INTEGER IDATB(3) REAL ETA(LP1),DETA(LM),AETA(LM) C C INCLUDE COMMON BLOCKS. C INCLUDE "IOUNIT.comm" INCLUDE "OMGAOT.comm" INCLUDE "CTLBLK.comm" INCLUDE "OUTFIL.comm" INCLUDE "LOOPS.comm" INCLUDE "MASKS.comm" INCLUDE "DYNAMD.comm" INCLUDE "PHYS2.comm" INCLUDE "MAPOT1.comm" INCLUDE "SRFDSP.comm" INCLUDE "CNVCLD.comm" INCLUDE "VRBLS.comm" INCLUDE "PVRBLS.comm" INCLUDE "BOCO.comm" INCLUDE "ACMCLD.comm" INCLUDE "ACMCLH.comm" INCLUDE "ACMPRE.comm" INCLUDE "ACMRDL.comm" INCLUDE "ACMRDS.comm" INCLUDE "ACMSFC.comm" INCLUDE "CLDWTR.comm" INCLUDE "SOIL.comm" INCLUDE "EXTRA.comm" INCLUDE "E2PFLG.comm" INCLUDE "INDX.comm" C C DELCARE NAMELIST. C NAMELIST /FCSTDATA/ & TSTART,TEND,TCP,RESTRT,SINGLRST &,SUBPOST,NMAP,TSHDE,SPL &,NPHS,NCNVC,NRADSH,NRADLH,NTDDMP &,TPREC,THEAT,TCLOD,TRDSW,TRDLW,TSRFC &,NEST,HYDRO,SPLINE C DATA BLANK/' '/ C C*********************************************************************** C START INIT HERE. C IF ( ME .EQ. 0 ) THEN WRITE(STDOUT,*)'INITPOST: ENTER INITPOST' WRITE(STDOUT,*)'INITPOST: SPLINE=', SPLINE ENDIF C C ***STEP 1. READ "NHB" NFILE. C C READ DATA FROM UNIT CONNECTED TO NHIBU. THIS DATA CONSISTS C OF "CONSTANTS" FOR A GIVEN ETA MODEL RUN. C LSL = LSM Cmp IF ( ME .EQ. 0 ) THEN LUNHB = 12 REWIND LUNHB open (unit=LUNHB,file='CNST.file',form='unformatted', + access='sequential') ENDIF Cmp C C IF ( ME .EQ. 0 ) READ(LUNHB) NFCST,NBC,LIST,DT,IDTAD,SIGMA, X KHLA,KHHA,KVLA,KVHA,KHL2,KHH2,KVL2,KVH2 CALL MPI_BCAST(NFCST, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(NBC , 1, MPI_INTEGER, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(LIST , 1, MPI_INTEGER, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(DT , 1, MPI_REAL , 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(IDTAD, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(SIGMA, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BARRIER(MPI_COMM_WORLD, IRTN) C cwas READ(LUNHB) LMH IF ( ME .EQ. 0 ) READ(LUNHB) DUMMY CALL EXTRACT(DUMMY,LMH) IF ( ME .EQ. 0 ) print*,"EXTRACT LMH" C cwas READ(LUNHB) LMV IF ( ME .EQ. 0 ) READ(LUNHB) DUMMY CALL EXTRACT(DUMMY,LMV) IF ( ME .EQ. 0 ) print*,"EXTRACT LMV" C C NEED ALL OF HBM2 FOR MPI TASK 0 IF ( ME .EQ. 0 ) READ(LUNHB) HBM2 CALL MPI_BCAST(HBM2,IM*JM, MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BARRIER(MPI_COMM_WORLD, IRTN) C C NEED ALL OF VBM2 FOR MPI TASK 0 IF ( ME .EQ. 0 ) READ(LUNHB) VBM2 CALL MPI_BCAST(VBM2,IM*JM, MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BARRIER(MPI_COMM_WORLD, IRTN) C cwas READ(LUNHB) VBM3 IF ( ME .EQ. 0 ) READ(LUNHB) DUMMY CALL EXTRACT(DUMMY,VBM3) IF ( ME .EQ. 0 ) print*,"EXTRACT VBM3" C cwas READ(LUNHB) IF ( ME .EQ. 0 ) READ(LUNHB) DUMMY CALL EXTRACT(DUMMY,SM) C cwas READ(LUNHB) SICE IF ( ME .EQ. 0 ) READ(LUNHB) DUMMY CALL EXTRACT(DUMMY,SICE) c DO L=1,LM C cwas READ(LUNHB)((HTM(I,J,L),I=1,IM),J=1,JM) IF ( ME .EQ. 0 ) READ(LUNHB) DUMMY CALL EXTRACT(DUMMY,HTM(1,1,L)) END DO C DO L=1,LM cwas READ(LUNHB)((VTM(I,J,L),I=1,IM),J=1,JM) IF ( ME .EQ. 0 ) READ(LUNHB)DUMMY CALL EXTRACT(DUMMY,VTM(1,1,L)) END DO C IF ( ME .EQ. 0 ) READ(LUNHB) DY,CPGFV,EN,ENT,R,PT,TDDAMP,F4D,F4Q, X EF4T,DETAD,RDETA,AETAD,F4Q2,ETAD,DFL,EM,EMT CALL MPI_BCAST(DY , 1 , MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(CPGFV , 1 , MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(EN , 1 , MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(ENT , 1 , MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(R , 1 , MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(PT , 1 , MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(TDDAMP , 1 , MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(F4D , 1 , MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(F4Q , 1 , MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(EF4T , 1 , MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(DETAD(1), LM , MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(RDETA(1), LM , MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(AETAD(1), LM , MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(F4Q2(1), LM , MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(ETAD(1), LP1, MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(DFL(1), LP1, MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(EM(1), JAM, MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(EMT(1), JAM, MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BARRIER(MPI_COMM_WORLD, IRTN) C cwas READ(LUNHB) DX IF ( ME .EQ. 0 ) READ(LUNHB) DUMMY CALL EXTRACT(DUMMY,DX) C cwas READ(LUNHB) WPDAR IF ( ME .EQ. 0 ) READ(LUNHB) DUMMY CALL EXTRACT(DUMMY,WPDAR) C cwas READ(LUNHB) CPGFU IF ( ME .EQ. 0 ) READ(LUNHB) DUMMY CALL EXTRACT(DUMMY,CPGFU) C cwas READ(LUNHB) CURV IF ( ME .EQ. 0 ) READ(LUNHB) DUMMY CALL EXTRACT(DUMMY,CURV) C cwas READ(LUNHB) FCP IF ( ME .EQ. 0 ) READ(LUNHB) DUMMY CALL EXTRACT(DUMMY,FCP) C cwas READ(LUNHB) FDIV IF ( ME .EQ. 0 ) READ(LUNHB) DUMMY CALL EXTRACT(DUMMY,FDIV) C cwas READ(LUNHB) FAD IF ( ME .EQ. 0 ) READ(LUNHB) DUMMY CALL EXTRACT(DUMMY,FAD) C cwas READ(LUNHB) F IF ( ME .EQ. 0 ) READ(LUNHB) DUMMY CALL EXTRACT(DUMMY,F) C cwas READ(LUNHB) DDMPU IF ( ME .EQ. 0 ) READ(LUNHB) DUMMY CALL EXTRACT(DUMMY,DDMPU) C cwas READ(LUNHB) DDMPV IF ( ME .EQ. 0 ) READ(LUNHB) DUMMY CALL EXTRACT(DUMMY,DDMPV) C IF ( ME .EQ. 0 ) READ(LUNHB) PT2,GLAT CALL MPI_BCAST(GLAT,IM*JM, MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(PT2,1, MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BARRIER(MPI_COMM_WORLD, IRTN) C IF ( ME .EQ. 0 ) READ(LUNHB) GLON CALL MPI_BCAST(GLON,IM*JM, MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BARRIER(MPI_COMM_WORLD, IRTN) C IF ( ME .EQ. 0 ) READ(LUNHB) PLQ,RDPQ,RDTHEQ,STHEQ,THE0Q CALL MPI_BCAST(PLQ , 1 , MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(RDPQ , 1 , MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(RDTHEQ , 1 , MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(STHEQ(1), ITBQ, MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(THE0Q(1), ITBQ, MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BARRIER(MPI_COMM_WORLD, IRTN) C IF ( ME .EQ. 0 ) READ(LUNHB) ROS,CS,DS,ROI,CI,DI,PL,THL,RDQ, X RDTH,RDP,RDTHE,DETA2,AETA2,DFRLG,QS0,SQS,STHE,THE0 CALL MPI_BCAST(ROS , 1 , MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(CS , 1 , MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(DS , 1 , MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(ROI , 1 , MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(CI , 1 , MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(DI , 1 , MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(PL , 1 , MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(THL , 1 , MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(RDQ , 1 , MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(RDTH , 1 , MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(RDP , 1 , MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(RDTHE , 1 , MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(DETA2(1), LM , MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(AETA2(1), LM , MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(DFRLG(1), LP1, MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST( QS0(1), JTB, MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST( SQS(1), JTB, MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST( STHE(1), ITB, MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST( THE0(1), ITB, MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BARRIER(MPI_COMM_WORLD, IRTN) C cwas READ(LUNHB) WFK IF ( ME .EQ. 0 ) READ(LUNHB) DUMMY CALL EXTRACT(DUMMY,WFK) C cwas READ(LUNHB) EPSR IF ( ME .EQ. 0 ) READ(LUNHB) DUMMY CALL EXTRACT(DUMMY,EPSR) C cwas READ(LUNHB) TG IF ( ME .EQ. 0 ) READ(LUNHB) DUMMY CALL EXTRACT(DUMMY,TG) C cwas READ(LUNHB) GFFC IF ( ME .EQ. 0 ) READ(LUNHB) DUMMY CALL EXTRACT(DUMMY,GFFC) C cwas READ(LUNHB) SST IF ( ME .EQ. 0 ) READ(LUNHB) DUMMY CALL EXTRACT(DUMMY,SST) C cwas READ(LUNHB) ALB IF ( ME .EQ. 0 ) READ(LUNHB) DUMMY CALL EXTRACT(DUMMY,ALB) C cwas READ(LUNHB) HDAC IF ( ME .EQ. 0 ) READ(LUNHB) DUMMY CALL EXTRACT(DUMMY,HDAC) C cwas READ(LUNHB) HDACV IF ( ME .EQ. 0 ) READ(LUNHB) DUMMY CALL EXTRACT(DUMMY,HDACV) C IF ( ME .EQ. 0 ) READ(LUNHB) TTBLQ CALL MPI_BCAST(TTBLQ(1,1),JTBQ*ITBQ,MPI_REAL,0,MPI_COMM_WORLD, X IRTN) CALL MPI_BARRIER(MPI_COMM_WORLD, IRTN) C IF ( ME .EQ. 0 ) READ(LUNHB) PTBL,TTBL,R1,PT1,TSPH,WBD,SBD, X TLM0D,TPH0D,DLMD,DPHD,CMLD,DP30,X1P,Y1P,IXM,IYM,DETA1,AETA1, X ETA1 CALL MPI_BCAST(PTBL(1,1),ITB*JTB,MPI_REAL, 0,MPI_COMM_WORLD,IRTN) CALL MPI_BCAST(TTBL(1,1),JTB*ITB,MPI_REAL, 0,MPI_COMM_WORLD,IRTN) CALL MPI_BCAST(R1,1, MPI_REAL , 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(PT1, 1, MPI_REAL , 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(TSPH, 1, MPI_REAL , 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(WBD, 1, MPI_REAL , 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(SBD, 1, MPI_REAL , 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(TLM0D, 1, MPI_REAL , 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(TPH0D, 1, MPI_REAL , 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(DLMD, 1, MPI_REAL , 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(DPHD, 1, MPI_REAL , 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(CMLD, 1, MPI_REAL , 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(DP30, 1, MPI_REAL , 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(X1P, 1, MPI_REAL , 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(Y1P, 1, MPI_REAL , 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(IXM, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(IYM, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(DETA1(1), LM, MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(AETA1(1), LM, MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(ETA1(1), LP1, MPI_REAL, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BARRIER(MPI_COMM_WORLD, IRTN) C cwas READ(LUNHB) IVGTYP IF ( ME .EQ. 0 ) READ(LUNHB) DUMMY CALL EXTRACT(DUMMY,IVGTYP) C cwas READ(LUNHB) ISLTYP IF ( ME .EQ. 0 ) READ(LUNHB) DUMMY CALL EXTRACT(DUMMY,ISLTYP) C cwas READ(LUNHB) ISLOPE IF ( ME .EQ. 0 ) READ(LUNHB) DUMMY CALL EXTRACT(DUMMY,ISLOPE) C cwas READ(LUNHB) VEGFRC IF ( ME .EQ. 0 ) READ(LUNHB) DUMMY CALL EXTRACT(DUMMY,VEGFRC) C IF ( ME .EQ. 0 ) READ(LUNHB) SLDPTH CALL MPI_BCAST(SLDPTH(1),NSOIL,MPI_REAL,0,MPI_COMM_WORLD,IRTN) CALL MPI_BARRIER(MPI_COMM_WORLD, IRTN) C IF ( ME .EQ. 0 ) READ(LUNHB) RTDPTH CALL MPI_BCAST(RTDPTH(1),NSOIL,MPI_REAL,0,MPI_COMM_WORLD,IRTN) CALL MPI_BARRIER(MPI_COMM_WORLD, IRTN) C IF ( ME .EQ. 0 ) THEN WRITE(STDOUT,*)'INITPOST: READ CONSTANTS FILE NHB' ENDIF C C COMPUTE DERIVED CONSTANTS FROM NHB INPUT. C PTDYN = PT RDYN = R DO L = 1,LM DETA(L) = DETAD(L) AETA(L) = AETAD(L) ETA(L) = ETAD(L) END DO ETA(LP1) = ETAD(LP1) C C C ***STEP 2. READ NAMELIST FCSTDATA. C C READ NAMELIST FCSTDATA WHICH CONTROLS TIMESTEPS, C ACCUMULATION PERIODS, AND STANDARD OUTPUT C RESTRT = .FALSE. LFCSTD = 11 C IF ( ME .EQ. 0 ) THEN open(LFCSTD,file='FCSTDATA.meso',status='old') REWIND LFCSTD READ(LFCSTD,FCSTDATA) C ENDIF C CALL MPI_BCAST(RESTRT,1, MPI_LOGICAL , 0, MPI_COMM_WORLD, IRTN) C CALL MPI_BCAST(NPHS,1, MPI_INTEGER , 0, MPI_COMM_WORLD, IRTN) C CALL MPI_BCAST(TPREC,1, MPI_REAL , 0, MPI_COMM_WORLD, IRTN) C CALL MPI_BCAST(THEAT,1, MPI_REAL , 0, MPI_COMM_WORLD, IRTN) C CALL MPI_BCAST(TCLOD,1, MPI_REAL , 0, MPI_COMM_WORLD, IRTN) C CALL MPI_BCAST(TRDSW,1, MPI_REAL , 0, MPI_COMM_WORLD, IRTN) C CALL MPI_BCAST(TRDLW,1, MPI_REAL , 0, MPI_COMM_WORLD, IRTN) C CALL MPI_BCAST(TSRFC,1, MPI_REAL , 0, MPI_COMM_WORLD, IRTN) C CALL MPI_BCAST(SPLINE,1, MPI_LOGICAL , 0, MPI_COMM_WORLD, IRTN) C CALL MPI_BARRIER(MPI_COMM_WORLD, IRTN) C CALL MPI_BCAST(TSHDE,9999999, MPI_REAL , 0, MPI_COMM_WORLD, IRTN) C CALL MPI_BARRIER(MPI_COMM_WORLD, IRTN) C CALL MPI_BCAST(SPL,LSM, MPI_REAL , 0, MPI_COMM_WORLD, IRTN) C CALL MPI_BARRIER(MPI_COMM_WORLD, IRTN) Cmp IF ( ME .EQ. 0 ) THEN write(6,*) 'what is spline???? ', SPLINE Cmp C WRITE(STDOUT,*)'INITPOST: READ NAMELIST ', X 'FCSTDATA - CONTENTS BELOW' WRITE(STDOUT,*)' TSTART,TEND : ',TSTART,TEND WRITE(STDOUT,*)' TCP : ',TCP WRITE(STDOUT,*)' RESTRT : ',RESTRT WRITE(STDOUT,*)' SUBPOST : ',SUBPOST WRITE(STDOUT,*)' NMAP,NPHS : ',NMAP,NPHS WRITE(STDOUT,*)' NRADSH,NRADLH: ',NRADSH,NRADLH WRITE(STDOUT,*)' TPREC,THEAT : ',TPREC,THEAT WRITE(STDOUT,*)' TCLOD,TRDSW : ',TCLOD,TRDSW WRITE(STDOUT,*)' TRDLW,TSRFC : ',TRDLW,TSRFC WRITE(STDOUT,*)' TSHDE (POSTED FORECAST HOURS) BELOW: ' WRITE(STDOUT,50) (TSHDE(K),K=1,99) WRITE(STDOUT,*)' SPL (POSTED PRESSURE LEVELS) BELOW: ' WRITE(STDOUT,51) (SPL(L),L=1,LSM) 50 FORMAT(14(F4.1,1X)) 51 FORMAT(8(F8.1,1X)) ENDIF C C COMPUTE DERIVED TIME STEPPING CONSTANTS. C FIRST = .TRUE. NSTART = INT(TSTART*TSPH+D50) NTSTM = INT(TEND *TSPH+D50)+1 NCP = INT(TCP *TSPH+D50) NDDAMP = INT(TDDAMP*TSPH+D50) NPREC = INT(TPREC *TSPH+D50) NHEAT = INT(THEAT *TSPH+D50) NCLOD = INT(TCLOD *TSPH+D50) NRDSW = INT(TRDSW *TSPH+D50) NRDLW = INT(TRDLW *TSPH+D50) NSRFC = INT(TSRFC *TSPH+D50) NRADS = NINT(TSPH)*NRADSH NRADL = NINT(TSPH)*NRADLH DTQ2 = NPHS * DT TDTQ2 = DTQ2 + DTQ2 DTD = D50 * DTQ2 TDTD = DTD + DTD KTM = INT(DTQ2/DTD+D50) C IF ( ME .EQ. 0 ) THEN WRITE(STDOUT,*)' ' WRITE(STDOUT,*)'DERIVED TIME STEPPING CONSTANTS' WRITE(STDOUT,*)' FIRST : ',FIRST WRITE(STDOUT,*)' NSTART,NSTSM,NCP : ',NSTART,NTSTM,NCP WRITE(STDOUT,*)' NDDAMP,NPREC,NHEAT: ',NDDAMP,NPREC,NHEAT WRITE(STDOUT,*)' NCLOD,NRDSW,NRDLW : ',NCLOD,NRDSW,NRDLW WRITE(STDOUT,*)' NSRFC : ',NSRFC WRITE(STDOUT,*)' NRADS,NRADL : ',NRADS,NRADL WRITE(STDOUT,*)' DTQ2,TDTQ2 : ',DTQ2,TDTQ2 WRITE(STDOUT,*)' DTD,TDTD,KTM : ',DTD,TDTD,KTM ENDIF C C COMPUTE DERIVED MAP OUTPUT CONSTANTS. DO L = 1,LSL ALSL(L) = LOG(SPL(L)) END DO DO I=1,NMAP ISHDE(I)=INT(TSHDE(I)*TSPH+D50)+1 END DO C C C C STEP 3. READ MODEL RESTART FILE C IF ( ME .EQ. 0 )WRITE(STDOUT,*)'INITPOST: READ RESTRT FILE' C ENVAR=' ' CALL GETENV("RSTFNL",ENVAR) CALL GETENV("tmmark",RESTHR) KPATH = INDEX(ENVAR,' ') -1 IF(KPATH.LE.0) KPATH = LEN(ENVAR) IF ( ME .EQ. 0 ) THEN print*,'kpath= ',kpath C write(6,*) 'itag= ', itag write(6,*) 'rstfil= ', rstfil write(6,*) 'resthr= ', resthr ENDIF IF(RESTHR.EQ.' ')THEN WRITE(RSTFIL,75)ITAG 75 FORMAT('RESTRT',I7.7) ELSE IF ( ME .EQ. 0 )write(6,*) 'using format 80 statement' WRITE(RSTFIL,80)ITAG,RESTHR IF ( ME .EQ. 0 )write(6,*) 'past format 80 write' 80 FORMAT('RESTRT',I7.7,'.',a4) ENDIF C KRST = INDEX(RSTFIL,' ') -1 IF(KRST.LE.0) KRST = LEN(RSTFIL) IF ( ME .EQ. 0 ) print *,'krst= ',krst C*** LRSTRT = 17 CLOSE(LRSTRT) C CALL ASNUNIT(LRSTRT,'-F cos -C ascii -N ibm',IER) C IF(IER.NE.0) C 1 WRITE(LIST,*)'INITPOST: ASNUNIT ERROR IER=',IER IF(ENVAR(1:4).EQ.BLANK) THEN OPEN(LRSTRT,FILE=RSTFIL,FORM='UNFORMATTED') ELSE FNAME = ENVAR(1:KPATH) // RSTFIL(1:KRST) OPEN(UNIT=LRSTRT,FILE=FNAME,FORM='UNFORMATTED',IOSTAT=IER) ENDIF C*** IF ( ME .EQ. 0 ) READ(LRSTRT) RUN,IDAT,IHRST,NTSD,LABEL,itag CALL MPI_BCAST(RUN,1,MPI_REAL,0,MPI_COMM_WORLD,IRTN) CALL MPI_BCAST(IDAT,3,MPI_INTEGER,0,MPI_COMM_WORLD,IRTN) CALL MPI_BCAST(IHRST,1,MPI_INTEGER,0,MPI_COMM_WORLD,IRTN) CALL MPI_BCAST(NTSD,1,MPI_INTEGER,0,MPI_COMM_WORLD,IRTN) CALL MPI_BCAST(itag,1,MPI_INTEGER,0,MPI_COMM_WORLD,IRTN) CALL MPI_BARRIER(MPI_COMM_WORLD,IRTN) C*** IF ( ME .EQ. 0 ) READ(LRSTRT) PDOMG,RESOMG C*** DO L = 1,LM cwas READ(LRSTRT) ((OMGA(I,J,L),I=1,IM),J=1,JM) IF ( ME .EQ. 0 ) READ(LRSTRT) DUMMY CALL EXTRACT(DUMMY,OMGA(1,1,L)) END DO C*** IF ( ME .EQ. 0 )WRITE(STDOUT,*)' READ ',LABEL C IF ( ME .EQ. 0 ) READ(LRSTRT) RUN,IDAT,IHRST,NTSD,LABEL,itag, & FIRST,IOUT,NSHDE CALL MPI_BCAST(FIRST,1,MPI_REAL,0,MPI_COMM_WORLD,IRTN) CALL MPI_BCAST(IOUT,1,MPI_INTEGER,0,MPI_COMM_WORLD,IRTN) CALL MPI_BCAST(NSHDE,1,MPI_INTEGER,0,MPI_COMM_WORLD,IRTN) CALL MPI_BARRIER(MPI_COMM_WORLD,IRTN) C*** CWAS READ(LRSTRT) PD,RES,FIS IF ( ME .EQ. 0 ) READ(LRSTRT) 1 (((DUMMY_MF(I,J,N),I=1,IM),J=1,JM),N=1,3) CALL EXTRACT(DUMMY_MF(1,1,1),PD) CALL EXTRACT(DUMMY_MF(1,1,2),RES) CALL EXTRACT(DUMMY_MF(1,1,3),FIS) C IF ( ME .EQ. 0 ) READ(LRSTRT) PDB,TB,QB,UB,VB CALL MPI_BCAST(PDB,LB*2,MPI_REAL,0,MPI_COMM_WORLD,IRTN) CALL MPI_BARRIER(MPI_COMM_WORLD,IRTN) CALL MPI_BCAST(TB,LB*LM*2,MPI_REAL,0,MPI_COMM_WORLD,IRTN) CALL MPI_BARRIER(MPI_COMM_WORLD,IRTN) CALL MPI_BCAST(QB,LB*LM*2,MPI_REAL,0,MPI_COMM_WORLD,IRTN) CALL MPI_BARRIER(MPI_COMM_WORLD,IRTN) CALL MPI_BCAST(UB,LB*LM*2,MPI_REAL,0,MPI_COMM_WORLD,IRTN) CALL MPI_BARRIER(MPI_COMM_WORLD,IRTN) CALL MPI_BCAST(VB,LB*LM*2,MPI_REAL,0,MPI_COMM_WORLD,IRTN) CALL MPI_BARRIER(MPI_COMM_WORLD,IRTN) C*** DO L = 1,LM IF ( ME .EQ. 0 ) READ(LRSTRT) DUMMY CALL EXTRACT(DUMMY,T(1,1,L)) IF ( ME .EQ. 0 ) READ(LRSTRT) DUMMY CALL EXTRACT(DUMMY,Q(1,1,L)) IF ( ME .EQ. 0 ) READ(LRSTRT) DUMMY CALL EXTRACT(DUMMY,U(1,1,L)) IF ( ME .EQ. 0 ) READ(LRSTRT) DUMMY CALL EXTRACT(DUMMY,V(1,1,L)) IF ( ME .EQ. 0 ) READ(LRSTRT) DUMMY CALL EXTRACT(DUMMY,Q2(1,1,L)) IF ( ME .EQ. 0 ) READ(LRSTRT) IF ( ME .EQ. 0 ) READ(LRSTRT) DUMMY CALL EXTRACT(DUMMY,CWM(1,1,L)) IF ( ME .EQ. 0 ) READ(LRSTRT) IF ( ME .EQ. 0 ) READ(LRSTRT) ENDDO C*** IF ( ME .EQ. 0 ) WRITE(STDOUT,*)' READ ',LABEL C cwas READ(LRSTRT) RUN,IDAT,IHRST,NTSD,LABEL cwas &, RSWIN,RSWOUT,TG,Z0,AKMS,CZEN IF ( ME .EQ. 0 ) READ(LRSTRT) RUN,IDAT,IHRST,NTSD,LABEL,itag 1, (((DUMMY_MF(I,J,N),I=1,IM),J=1,JM),N=1,6) CALL EXTRACT(DUMMY_MF(1,1,1),RSWIN) CALL EXTRACT(DUMMY_MF(1,1,2),RSWOUT) CALL EXTRACT(DUMMY_MF(1,1,3),TG) CALL EXTRACT(DUMMY_MF(1,1,4),Z0) CALL EXTRACT(DUMMY_MF(1,1,5),AKMS) CALL EXTRACT(DUMMY_MF(1,1,6),CZEN) C*** cwas READ(LRSTRT) AKHS,THS,QS,TWBS,QWBS,HBOT,CFRACL IF ( ME .EQ. 0 ) READ(LRSTRT) 1 (((DUMMY_MF(I,J,N),I=1,IM),J=1,JM),N=1,7) CALL EXTRACT(DUMMY_MF(1,1,1),AKHS) CALL EXTRACT(DUMMY_MF(1,1,2),THS) CALL EXTRACT(DUMMY_MF(1,1,3),QS) CALL EXTRACT(DUMMY_MF(1,1,4),TWBS) CALL EXTRACT(DUMMY_MF(1,1,5),QWBS) CALL EXTRACT(DUMMY_MF(1,1,6),HBOT) CALL EXTRACT(DUMMY_MF(1,1,7),CFRACL) C*** cwas READ(LRSTRT) THZ0,QZ0,UZ0,VZ0,USTAR,HTOP,CFRACM IF ( ME .EQ. 0 ) READ(LRSTRT) 1 (((DUMMY_MF(I,J,N),I=1,IM),J=1,JM),N=1,7) CALL EXTRACT(DUMMY_MF(1,1,1),THZ0) CALL EXTRACT(DUMMY_MF(1,1,2),QZ0) CALL EXTRACT(DUMMY_MF(1,1,3),UZ0) CALL EXTRACT(DUMMY_MF(1,1,4),VZ0) CALL EXTRACT(DUMMY_MF(1,1,5),USTAR) CALL EXTRACT(DUMMY_MF(1,1,6),HTOP) CALL EXTRACT(DUMMY_MF(1,1,7),CFRACM) C*** CWAS READ(LRSTRT) SNO,WET,CLDEFI,RF,PSLP,CUPPT,CFRACH CCHOUWAS READ(LRSTRT) SNO, SI,CLDEFI,RF,PSLP,CUPPT,CFRACH IF ( ME .EQ. 0 ) READ(LRSTRT) 1 (((DUMMY_MF(I,J,N),I=1,IM),J=1,JM),N=1,7) CALL EXTRACT(DUMMY_MF(1,1,1),SNO) CALL EXTRACT(DUMMY_MF(1,1,2),SI) !Chou 20221225 EXTRACT(DUMMY,WET) SI is the name in etafcst CALL EXTRACT(DUMMY_MF(1,1,3),CLDEFI) CALL EXTRACT(DUMMY_MF(1,1,4),RF) CALL EXTRACT(DUMMY_MF(1,1,5),PSLP) CALL EXTRACT(DUMMY_MF(1,1,6),CUPPT) CALL EXTRACT(DUMMY_MF(1,1,7),CFRACH) C C*** cwas READ(LRSTRT) SOILTB,SFCEXC,SMSTAV,SMSTOT,GRNFLX,PCTSNO IF ( ME .EQ. 0 ) READ(LRSTRT) 1 (((DUMMY_MF(I,J,N),I=1,IM),J=1,JM),N=1,6) CALL EXTRACT(DUMMY_MF(1,1,1),SOILTB) CALL EXTRACT(DUMMY_MF(1,1,2),SFCEXC) CALL EXTRACT(DUMMY_MF(1,1,3),SMSTAV) CALL EXTRACT(DUMMY_MF(1,1,4),SMSTOT) CALL EXTRACT(DUMMY_MF(1,1,5),GRNFLX) CALL EXTRACT(DUMMY_MF(1,1,6),PCTSNO) C*** CWAS READ(LRSTRT) RLWIN,RADOT,CZMEAN,SIGT4 IF ( ME .EQ. 0 ) READ(LRSTRT) 1 (((DUMMY_MF(I,J,N),I=1,IM),J=1,JM),N=1,4) CALL EXTRACT(DUMMY_MF(1,1,1),RLWIN) CALL EXTRACT(DUMMY_MF(1,1,2),RADOT) CALL EXTRACT(DUMMY_MF(1,1,3),CZMEAN) CALL EXTRACT(DUMMY_MF(1,1,4),SIGT4) C*** CWAS READ(LRSTRT) U00,UL,LC,SR IF ( ME .EQ. 0 ) READ(LRSTRT) 1 (((DUMMY_MF(I,J,N),I=1,IM),J=1,JM),N=1,3) CALL EXTRACT(DUMMY_MF(1,1,1),U00) CALL EXTRACT(DUMMY_MF(1,1,2),LC) CALL EXTRACT(DUMMY_MF(1,1,3),SR) C*** IF ( ME .EQ. 0 ) WRITE(STDOUT,*)' READ ',LABEL C CWAS READ(LRSTRT) RUN,IDAT,IHRST,NTSD,LABEL, CWAS & PREC,ACPREC,ACCLIQ,CUPREC IF ( ME .EQ. 0 ) READ(LRSTRT) RUN,IDAT,IHRST,NTSD,LABEL,itag 1, (((DUMMY_MF(I,J,N),I=1,IM),J=1,JM),N=1,4) CALL EXTRACT(DUMMY_MF(1,1,1),PREC) CALL EXTRACT(DUMMY_MF(1,1,2),ACPREC) CALL EXTRACT(DUMMY_MF(1,1,3),ACCLIQ) CALL EXTRACT(DUMMY_MF(1,1,4),CUPREC) C*** cwas READ(LRSTRT) ACFRCV,NCFRCV,ACFRST,NCFRST IF ( ME .EQ. 0 ) READ(LRSTRT) 1 (((DUMMY_MF(I,J,N),I=1,IM),J=1,JM),N=1,4) CALL EXTRACT(DUMMY_MF(1,1,1),ACFRCV) CALL EXTRACT(DUMMY_MF(1,1,2),NCFRCV) CALL EXTRACT(DUMMY_MF(1,1,3),ACFRST) CALL EXTRACT(DUMMY_MF(1,1,4),NCFRST) C** cwas READ(LRSTRT) ACSNOW,ACSNOM,SSROFF,BGROFF IF ( ME .EQ. 0 ) READ(LRSTRT) 1 (((DUMMY_MF(I,J,N),I=1,IM),J=1,JM),N=1,4) CALL EXTRACT(DUMMY_MF(1,1,1),ACSNOW) CALL EXTRACT(DUMMY_MF(1,1,2),ACSNOM) CALL EXTRACT(DUMMY_MF(1,1,3),SSROFF) CALL EXTRACT(DUMMY_MF(1,1,4),BGROFF) C*** cwas READ(LRSTRT) SFCSHX,SFCLHX,SUBSHX,SNOPCX cwas 1, SFCUVX,SFCEVP,POTEVP IF ( ME .EQ. 0 ) READ(LRSTRT) 1 (((DUMMY_MF(I,J,N),I=1,IM),J=1,JM),N=1,7) CALL EXTRACT(DUMMY_MF(1,1,1),SFCSHX) CALL EXTRACT(DUMMY_MF(1,1,2),SFCLHX) CALL EXTRACT(DUMMY_MF(1,1,3),SUBSHX) CALL EXTRACT(DUMMY_MF(1,1,4),SNOPCX) CALL EXTRACT(DUMMY_MF(1,1,5),SFCUVX) CALL EXTRACT(DUMMY_MF(1,1,6),SFCEVP) CALL EXTRACT(DUMMY_MF(1,1,7),POTEVP) C*** cwas READ(LRSTRT) ASWIN,ASWOUT,ASWTOA,ALWIN,ALWOUT,ALWTOA IF ( ME .EQ. 0 ) READ(LRSTRT) 1 (((DUMMY_MF(I,J,N),I=1,IM),J=1,JM),N=1,6) CALL EXTRACT(DUMMY_MF(1,1,1),ASWIN) CALL EXTRACT(DUMMY_MF(1,1,2),ASWOUT) CALL EXTRACT(DUMMY_MF(1,1,3),ASWTOA) CALL EXTRACT(DUMMY_MF(1,1,4),ALWIN) CALL EXTRACT(DUMMY_MF(1,1,5),ALWOUT) CALL EXTRACT(DUMMY_MF(1,1,6),ALWTOA) C*** IF ( ME .EQ. 0 ) READ(LRSTRT) ARDSW,ARDLW,ASRFC,AVRAIN,AVCNVC CALL MPI_BCAST(ARDSW, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(ARDLW, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(ASRFC, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(AVRAIN,1, MPI_INTEGER, 0, MPI_COMM_WORLD, IRTN) CALL MPI_BCAST(AVCNVC,1, MPI_INTEGER, 0, MPI_COMM_WORLD, IRTN) C*** cwas READ(LRSTRT) TH10,Q10,U10,V10,TSHLTR,QSHLTR,PSHLTR IF ( ME .EQ. 0 ) READ(LRSTRT) 1 (((DUMMY_MF(I,J,N),I=1,IM),J=1,JM),N=1,13) CALL EXTRACT(DUMMY_MF(1,1,1),TH10) CALL EXTRACT(DUMMY_MF(1,1,2),Q10) CALL EXTRACT(DUMMY_MF(1,1,3),U10) CALL EXTRACT(DUMMY_MF(1,1,4),V10) CALL EXTRACT(DUMMY_MF(1,1,5),TSHLTR) CALL EXTRACT(DUMMY_MF(1,1,6),QSHLTR) CALL EXTRACT(DUMMY_MF(1,1,7),PSHLTR) CGSM v100m CALL EXTRACT(DUMMY_MF(1,1,8),TH100) CALL EXTRACT(DUMMY_MF(1,1,9),Q100) CALL EXTRACT(DUMMY_MF(1,1,10),U100) CALL EXTRACT(DUMMY_MF(1,1,11),V100) CGSM v100m CLYRA GSM Wind stress CALL EXTRACT(DUMMY_MF(1,1,12),XMOMFLUX) CALL EXTRACT(DUMMY_MF(1,1,13),YMOMFLUX) CLYRA GSM Wind stress C*** cwas READ(LRSTRT) (((SMC(I,J,N),I=1,IM),J=1,JM),N=1,NSOIL) IF ( ME .EQ. 0 ) READ(LRSTRT) 1 (((DUMMY_MF(I,J,N),I=1,IM),J=1,JM),N=1,NSOIL) DO II=1, NSOIL CALL EXTRACT(DUMMY_MF(1,1,II),SMC(:,:,II)) ENDDO C IF ( ME .EQ. 0 ) READ(LRSTRT) C*** cwas READ(LRSTRT) CMC IF ( ME .EQ. 0 ) READ(LRSTRT) DUMMY CALL EXTRACT(DUMMY,CMC) C*** cwas READ(LRSTRT) (((STC(I,J,N),I=1,IM),J=1,JM),N=1,NSOIL) IF ( ME .EQ. 0 ) READ(LRSTRT) 1 (((DUMMY_MF(I,J,N),I=1,IM),J=1,JM),N=1,NSOIL) DO II=1, NSOIL CALL EXTRACT(DUMMY_MF(1,1,II),STC(:,:,II)) ENDDO C IF ( ME .EQ. 0 ) READ(LRSTRT) Chou 13/06/2009 more fields available in restrt file IF ( ME .EQ. 0 ) READ(LRSTRT) 1 (((DUMMY_MF(I,J,N),I=1,IM),J=1,JM),N=1,NSOIL) DO II=1, NSOIL CJLG CALL EXTRACT(DUMMY_MF(:,:,II),SH2O(:,:,II)) ENDDO IF ( ME .EQ. 0 ) READ(LRSTRT) IF ( ME .EQ. 0 ) READ(LRSTRT) 1 (((DUMMY_MF(I,J,N),I=1,IM),J=1,JM),N=1,5) cANDRE(RESTRT) READ(LRSTRT) DUMMY cANDRE(RESTRT) READ(LRSTRT) DUMMY CALL EXTRACT(DUMMY_MF(1,1,2),TLMIN) CALL EXTRACT(DUMMY_MF(1,1,3),TLMAX) Chou to reach TLMAX and TLMIN c Lyra GSM Max wind CALL EXTRACT(DUMMY_MF(1,1,4),MAXWU) CALL EXTRACT(DUMMY_MF(1,1,5),MAXWV) c Lyra GSM Max wind C*** IF ( ME .EQ. 0 ) WRITE(STDOUT,*)'END OF RESTART FILE READ' C C END OF RESTART FILE READ. C C CLOSE THE RESTART FILE. CLOSE(LRSTRT) C C SET UP THESE FLAGS FOR ETA2P C IOOMG=.FALSE. IOALL=.FALSE. C*** C*** BOUND SR BY 0 AND 1 C*** DO J=JSTA,JEND DO I=1,IM SR(I,J)=MAX(SR(I,J),0.) SR(I,J)=MIN(SR(I,J),1.) ENDDO ENDDO C*** C*** FILL IN THE EXTRA-LEVEL ARRAYS WITH VALUES AT L=LM C*** WHEREVER THERE ARE NO STEPS. C*** DO J=JSTA,JEND DO I=1,IM LMHK=LMH(I,J) IF(LMHK.EQ.LM)THEN PDSL(I,J)=RES(I,J)*PD(I,J) TH10(I,J)=T(I,J,LM)*(1.0E5/(AETA(LM)*PDSL(I,J)+PT))**CAPA Q10(I,J)=Q(I,J,LM) ENDIF ENDDO ENDDO C CHOU 20221229 DO J=JSTA,JEND CHOU 20221229 DO I=1,IM CHOU 20221229 LMVK=LMV(I,J) CHOU 20221229 IF(LMVK.EQ.LM)THEN CHOU 20221229 U10(I,J)=U(I,J,LM) CHOU 20221229 V10(I,J)=V(I,J,LM) CHOU 20221229 ENDIF CHOU 20221229 ENDDO CHOU 20221229 ENDDO C C CLIP NEGATIVE SPECIFIC HUMIDITY. C DO 100 L=1,LM CALL BOUNDL(Q(1,1,L),H1M12,H99999,IM,JM) 100 CONTINUE IF ( ME .EQ. 0 ) X WRITE(STDOUT,*)'INITPOST: CLIP NEGATIVE SPECIFIC HUMIDITY' C C COMPUTE PRESSURE AND LN(P) AT INTERFACES. C SET SURFACE VALUES. C !$omp parallel do !$omp& private(pbi) DO J=JSTA,JEND DO I=1,IM PDSL(I,J) =RES(I,J)*PD(I,J) PBI =PD(I,J)+PT PINT(I,J,LP1) =PBI ALPINT(I,J,LP1)=ALOG(PBI) ENDDO ENDDO C C COMPUTE OMEGA ON ETA LEVELS. C !$omp parallel do !$omp& private(rtopkl) DO 125 L=1,LM DO J=JSTA,JEND DO I=1,IM RTOPKL=RDYN*T(I,J,L)*(H1+D608*Q(I,J,L))/ 1 (PDSL(I,J)*AETA(L)+PT) IF(ABS(RTOPKL).GT.H1M12) 1 OMGA(I,J,L)=OMGA(I,J,L)*CP/(RTOPKL*DT) ENDDO ENDDO 125 CONTINUE C C CALCULATE AVERAGE PRESSURE DIFFERENCE BETWEEN ETA=1 AND ETA=0 C AT VELOCITY POINTS (PDVP1) USING THE VALUES ALREADY KNOWN AT C HEIGHT POINTS (PDSL). C CALL EXCH(PDSL) !$omp parallel do DO J=2,JM-1,2 DO I=2,IM-1 PDVP1(I,J)=0.25*(PDSL(I-1,J)+PDSL(I,J) 1 +PDSL(I,J+1)+PDSL(I,J-1)) ENDDO ENDDO !$omp parallel do DO J=3,JM-1,2 DO I=1,IM-1 PDVP1(I,J)=0.25*(PDSL(I+1,J)+PDSL(I,J) 1 +PDSL(I,J+1)+PDSL(I,J-1)) ENDDO ENDDO C !$omp parallel do DO I=1,IM-1 PDVP1(I,1)=0.5*(PDSL(I,1)+PDSL(I+1,1)) PDVP1(I,JM)=0.5*(PDSL(I,JM)+PDSL(I+1,JM)) ENDDO C !$omp parallel do DO J=2,JM-1,2 PDVP1(1,J)=0.5*(PDSL(1,J-1)+PDSL(1,J+1)) PDVP1(IM,J)=0.5*(PDSL(IM,J-1)+PDSL(IM,J+1)) ENDDO C PDVP1(IM,JM)=PDVP1(IM-1,JM) C C FIND THE HIGHEST ETA LAYER CONTAINING MOUNTAINS. C DO 150 L=LM,1,-1 C DO J=JSTA,JEND DO I=1,IM IF (HTM(I,J,L).EQ.D00)GO TO 150 ENDDO ENDDO C LHMNT=L+1 GO TO 155 150 CONTINUE 155 IF(LHMNT.EQ.LP1)THEN CHOU 20230201 IF(.NOT.SIGMA)THEN GO TO 175 CHOU 20230201 ELSE CHOU 20230201 LHMNT = LM CHOU 20230201 ENDIF ENDIF C*** C*** NOW GATHER THE ADDRESSES OF ALL THE UNDERGROUND POINTS. C*** do170: DO L=LHMNT,LM KMN=0 KMNTM(L)=0 C K=0 doout160: DO J=1,JM IEND=IM IF(MOD(J,2).EQ.0)IEND=IM-1 doin160: DO I=1,IEND K=K+1 IF ( J .GE. JSTA .AND. J .LE. JEND ) THEN KMNT(K,L)=0 IF(HTM(I,J,L).EQ.H1)CYCLE doin160 KMN=KMN+1 KMNT(KMN,L)=K END IF END DO doin160 END DO doout160 KMNTM(L)=KMN END DO do170 175 CONTINUE C C COMPUTE PRESSURE VALUES ABOVE THE SURFACE. C !$omp parallel do !$omp& private(pbi) DO L=LM,1,-1 DO J=JSTA,JEND DO I=1,IM PBI =PDSL(I,J)*ETA(L)+PT PINT(I,J,L) =PBI ALPINT(I,J,L)=ALOG(PBI) ENDDO ENDDO ENDDO C C COMPUTE PRESSURE VALUES BELOW THE SURFACE. C KMM=KMNTM(LM) DO KM=1,KMM K=KMNT(KM,LM) NDROW=K/IMT LFTOV1=MOD(K,IMT) IF(LFTOV1-IM.GT.0)THEN I=K-NDROW*IMT-IM IADD=2 ELSEIF(LFTOV1.GT.0)THEN I=K-NDROW*IMT IADD=1 ELSEIF(LFTOV1.EQ.0)THEN I=IM-1 IADD=0 ENDIF J=2*NDROW+IADD C C COMPUTE ALPINT AND PINT ONLY FOR THOSE POINTS THAT WE OWN C C IF ( J .GE. JSTA .AND. J .LE. JEND ) THEN C LMAP1=LMH(I,J)+1 DO L=LMAP1,LM ALPINT(I,J,L+1)=(DFL(L)-DFL(L+1))/(R*T(I,J,L)) 1 +ALPINT(I,J,L) PINT(I,J,L+1)=EXP(ALPINT(I,J,L+1)) ENDDO C END IF ENDDO C C CALCULATE THE I-INDEX EAST-WEST INCREMENTS C DO J=1,JM IHE(J)=MOD(J+1,2) IHW(J)=IHE(J)-1 IVE(J)=MOD(J,2) IVW(J)=IVE(J)-1 ENDDO C IF ( ME .EQ. 0 ) THEN WRITE(STDOUT,*)'INITPOST: COMPLETE ONE TIME CALCULATIONS' ENDIF C C END OF ROUTINE. C IF ( ME .EQ. 0 ) THEN WRITE(STDOUT,*)'INITPOST: ALL INPUT DATA READ/PREPARED.' WRITE(STDOUT,*)' ' ENDIF CALL MPI_BARRIER(MPI_COMM_WORLD,IRTN) RETURN END