From f4abd5f1c8f4c1634931d23577e8acc53a57b019 Mon Sep 17 00:00:00 2001 From: Wen Meng Date: Fri, 14 Jan 2022 17:52:31 +0000 Subject: [PATCH 1/8] Remove read interfaces INITPOST_GFS_NEMS, INITPOST_GFS_NEMS_MPIIO and INITPOST_GFS_NMM. --- sorc/ncep_post.fd/CMakeLists.txt | 3 --- sorc/ncep_post.fd/WRFPOST.f | 13 +------------ 2 files changed, 1 insertion(+), 15 deletions(-) diff --git a/sorc/ncep_post.fd/CMakeLists.txt b/sorc/ncep_post.fd/CMakeLists.txt index 5fba419fc..551a378b5 100644 --- a/sorc/ncep_post.fd/CMakeLists.txt +++ b/sorc/ncep_post.fd/CMakeLists.txt @@ -150,14 +150,11 @@ list(APPEND EXE_SRC GETNEMSNDSCATTER.f GFSPOSTSIG.F INITPOST.F - INITPOST_GFS_NEMS.f INITPOST_GFS_NEMS_MPIIO.f INITPOST_GFS_NETCDF.f INITPOST_GFS_NETCDF_PARA.f INITPOST_NEMS.f - INITPOST_NEMS_MPIIO.f INITPOST_NETCDF.f - INITPOST_NMM.f WRFPOST.f getIVariableN.f getVariable.f diff --git a/sorc/ncep_post.fd/WRFPOST.f b/sorc/ncep_post.fd/WRFPOST.f index 571174dd7..51d3dc629 100644 --- a/sorc/ncep_post.fd/WRFPOST.f +++ b/sorc/ncep_post.fd/WRFPOST.f @@ -648,9 +648,6 @@ PROGRAM WRFPOST IF(MODELNAME == 'NCAR' .OR. MODELNAME == 'RAPR') THEN print*,'CALLING INITPOST TO PROCESS NCAR NETCDF OUTPUT' CALL INITPOST - ELSE IF(MODELNAME == 'NMM') THEN - print*,'CALLING INITPOST_NMM TO PROCESS NMM NETCDF OUTPUT' - CALL INITPOST_NMM ELSE IF (MODELNAME == 'FV3R') THEN ! use netcdf library to read output directly print*,'CALLING INITPOST_NETCDF' @@ -680,10 +677,6 @@ PROGRAM WRFPOST ELSE IF(TRIM(IOFORM) == 'binarynemsio') THEN IF(MODELNAME == 'NMM') THEN CALL INITPOST_NEMS(NREC,nfile) - ELSE IF(MODELNAME == 'GFS') THEN -! CALL INITPOST_GFS_NEMS(NREC,iostatusFlux,iostatusD3D,nfile,ffile) - CALL INITPOST_GFS_NEMS(NREC,iostatusFlux,iostatusD3D,iostatusAER, & - nfile,ffile,rfile) ELSE PRINT*,'POST does not have nemsio option for model,',MODELNAME,' STOPPING,' STOP 9998 @@ -691,11 +684,7 @@ PROGRAM WRFPOST END IF ELSE IF(TRIM(IOFORM) == 'binarynemsiompiio')THEN - IF(MODELNAME == 'NMM') THEN -! close nemsio file for serial read - call nemsio_close(nfile,iret=status) - CALL INITPOST_NEMS_MPIIO() - ELSE IF(MODELNAME == 'GFS') THEN + IF(MODELNAME == 'GFS') THEN ! close nemsio file for serial read call nemsio_close(nfile,iret=status) call nemsio_close(ffile,iret=status) From 6360d2185b082656167ce84d117a2da28f6bd331 Mon Sep 17 00:00:00 2001 From: Wen Meng Date: Fri, 14 Jan 2022 18:00:35 +0000 Subject: [PATCH 2/8] Change linking order for w3nco and nemsio --- sorc/ncep_post.fd/CMakeLists.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/sorc/ncep_post.fd/CMakeLists.txt b/sorc/ncep_post.fd/CMakeLists.txt index 551a378b5..0855a7788 100644 --- a/sorc/ncep_post.fd/CMakeLists.txt +++ b/sorc/ncep_post.fd/CMakeLists.txt @@ -221,8 +221,8 @@ if(BUILD_POSTEXEC) add_executable(${EXENAME} ${EXE_SRC}) target_link_libraries(${EXENAME} PRIVATE ${LIBNAME} - w3nco::w3nco_4 nemsio::nemsio + w3nco::w3nco_4 sp::sp_4 sfcio::sfcio sigio::sigio) From 2950ec694b70a181b640f95cd16698c44c0dc5b0 Mon Sep 17 00:00:00 2001 From: Wen Meng Date: Sat, 15 Jan 2022 00:10:19 +0000 Subject: [PATCH 3/8] Remove INITPOST_GFS_NETCDF --- sorc/ncep_post.fd/CMakeLists.txt | 1 - sorc/ncep_post.fd/WRFPOST.f | 43 +++----------------------------- 2 files changed, 4 insertions(+), 40 deletions(-) diff --git a/sorc/ncep_post.fd/CMakeLists.txt b/sorc/ncep_post.fd/CMakeLists.txt index 0855a7788..f2c32337e 100644 --- a/sorc/ncep_post.fd/CMakeLists.txt +++ b/sorc/ncep_post.fd/CMakeLists.txt @@ -151,7 +151,6 @@ list(APPEND EXE_SRC GFSPOSTSIG.F INITPOST.F INITPOST_GFS_NEMS_MPIIO.f - INITPOST_GFS_NETCDF.f INITPOST_GFS_NETCDF_PARA.f INITPOST_NEMS.f INITPOST_NETCDF.f diff --git a/sorc/ncep_post.fd/WRFPOST.f b/sorc/ncep_post.fd/WRFPOST.f index 51d3dc629..e6e3e8ab4 100644 --- a/sorc/ncep_post.fd/WRFPOST.f +++ b/sorc/ncep_post.fd/WRFPOST.f @@ -44,6 +44,8 @@ !! 21-06-20 W Meng - remove reading grib1 and gfsio lib !! 21-10-22 KaYee Wong - created formal fortran namelist for itag !! 21-11-03 Tracy Hertneky - Removed SIGIO option +!! 22-01-14 W Meng - Remove interfaces INITPOST_GS_NEMS, INITPOST_NEMS_MPIIO +!! INITPOST_NMM and INITPOST_GFS_NETCDF. !! !! USAGE: WRFPOST !! INPUT ARGUMENT LIST: @@ -272,11 +274,6 @@ PROGRAM WRFPOST ,trim(fileName),trim(fileNameFlux) end if -! -! set ndegr -! if(grib=='grib1') then -! gdsdegr = 1000. -! else if (grib=='grib2') then if(grib=='grib2') then gdsdegr = 1.d6 endif @@ -302,14 +299,7 @@ PROGRAM WRFPOST !set control file name fileNameFlat='postxconfig-NT.txt' -!KaYee if(MODELNAME == 'RAPR') then -!KaYee read(5,*,iostat=iret,end=119) kpo -!KaYee else - read(5,nampgb,iostat=iret,end=119) -!KaYee endif -! if(kpo > komax)print*,'pressure levels cannot exceed ',komax; STOP -! if(kth > komax)print*,'isent levels cannot exceed ',komax; STOP -! if(kpv > komax)print*,'PV levels cannot exceed ',komax; STOP + read(5,nampgb,iostat=iret,end=119) 119 continue if(me == 0) then print*,'komax,iret for nampgb= ',komax,iret @@ -332,15 +322,6 @@ PROGRAM WRFPOST if(me == 0) then print*,'using pressure levels from POSTGPVARS' endif -!KaYee if(MODELNAME == 'RAPR')then -!KaYee read(5,*) (po(l),l=1,kpo) -! CRA READ VALID TIME UNITS -!KaYee read(5,121) VTIMEUNITS -!KaYee if(me == 0) then -!KaYee print*,'VALID TIME UNITS = ', VTIMEUNITS -!KaYee endif -! CRA -!KaYee endif lsm = kpo if( .not. popascal ) then untcnvt = 100. @@ -360,21 +341,8 @@ PROGRAM WRFPOST LSMP1 = LSM+1 if (me==0) print*,'LSM, SPL = ',lsm,spl(1:lsm) -!Chuang, Jun and Binbin: If model is RSM, read in precip accumulation frequency (sec) from unit5 - if(MODELNAME == 'RSM') then - read(5,115)PRNTSEC - TPREC = PRNTSEC/3600.0 - print*,'TPREC in RSM= ',TPREC - end if - 115 format(f7.1) 116 continue -!KaYee if(MODELNAME == 'GFS') then -! read(5,*) line -!KaYee read(5,111,end=125) fileNameFlat -!KaYee 125 continue -! if(len_trim(fileNameFlat)<5) fileNameFlat = 'postxconfig-NT.txt' -!KaYee if (me == 0) print*,'Post flat name in GFS= ',trim(fileNameFlat) -!KaYee endif + ! set PTHRESH for different models if(MODELNAME == 'NMM')then PTHRESH = 0.000004 @@ -652,9 +620,6 @@ PROGRAM WRFPOST ! use netcdf library to read output directly print*,'CALLING INITPOST_NETCDF' CALL INITPOST_NETCDF(ncid2d,ncid3d) - ELSE IF (MODELNAME == 'GFS') THEN - print*,'CALLING INITPOST_GFS_NETCDF' - CALL INITPOST_GFS_NETCDF(ncid3d) ELSE PRINT*,'POST does not have netcdf option for model,',MODELNAME,' STOPPING,' STOP 9998 From f374ecbc8d878fb927d161f5e806c97a23c19948 Mon Sep 17 00:00:00 2001 From: Wen Meng Date: Sat, 15 Jan 2022 00:15:19 +0000 Subject: [PATCH 4/8] Remove INITPOST_GFS_NEMS.f, INITPOST_GFS_NETCDF.f, INITPOST_NEMS.f, INITPOST_NEMS_MPIIO.f from UPP code. --- sorc/ncep_post.fd/INITPOST_GFS_NEMS.f | 3264 ----------------------- sorc/ncep_post.fd/INITPOST_GFS_NETCDF.f | 2761 ------------------- sorc/ncep_post.fd/INITPOST_NEMS.f | 2851 -------------------- sorc/ncep_post.fd/INITPOST_NEMS_MPIIO.f | 2464 ----------------- 4 files changed, 11340 deletions(-) delete mode 100644 sorc/ncep_post.fd/INITPOST_GFS_NEMS.f delete mode 100644 sorc/ncep_post.fd/INITPOST_GFS_NETCDF.f delete mode 100644 sorc/ncep_post.fd/INITPOST_NEMS.f delete mode 100644 sorc/ncep_post.fd/INITPOST_NEMS_MPIIO.f diff --git a/sorc/ncep_post.fd/INITPOST_GFS_NEMS.f b/sorc/ncep_post.fd/INITPOST_GFS_NEMS.f deleted file mode 100644 index 2f04cfb7e..000000000 --- a/sorc/ncep_post.fd/INITPOST_GFS_NEMS.f +++ /dev/null @@ -1,3264 +0,0 @@ -!> @file -! . . . -!> SUBPROGRAM: INITPOST INITIALIZE POST FOR RUN -!! PRGRMMR: Hui-Ya Chuang DATE: 2007-03-01 -!! -!! ABSTRACT: THIS ROUTINE INITIALIZES CONSTANTS AND -!! VARIABLES AT THE START OF GFS MODEL OR POST -!! PROCESSOR RUN. -!! -!! REVISION HISTORY -!! 2011-02-07 Jun Wang add grib2 option -!! 2011-12-14 Sarah Lu add aer option -!! 2012-01-07 Sarah Lu compute air density -!! 2012-12-22 Sarah Lu add aerosol zerout option -!! 2015-03-16 S. Moorthi adding gocart_on option -!! 2015-03-18 S. Moorthi Optimization including threading -!! 2015-08-17 S. Moorthi Add TKE for NEMS/GSM -!! 2021-03-11 Bo Cui change local arrays to dimension (im,jsta:jend) -!! -!! USAGE: CALL INIT -!! INPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - CTLBLK -!! LOOKUP -!! SOILDEPTH -!! -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : CRAY C-90 -!! - SUBROUTINE INITPOST_GFS_NEMS(NREC,iostatusFlux,iostatusD3D, & - iostatusAER,nfile,ffile,rfile) -! SUBROUTINE INITPOST_GFS_NEMS(NREC,iostatusFlux,iostatusD3D,nfile,ffile) - - - use vrbls4d, only: dust, SALT, SUSO, SOOT, WASO - use vrbls3d, only: t, q, uh, vh, pmid, pint, alpint, dpres, zint, zmid, o3, & - qqr, qqs, cwm, qqi, qqw, omga, rhomid, q2, cfr, rlwtt, rswtt, tcucn, & - tcucns, train, el_pbl, exch_h, vdifftt, vdiffmois, dconvmois, nradtt, & - o3vdiff, o3prod, o3tndy, mwpv, unknown, vdiffzacce, zgdrag,cnvctummixing, & - vdiffmacce, mgdrag, cnvctvmmixing, ncnvctcfrac, cnvctumflx, cnvctdmflx, & - cnvctzgdrag, sconvmois, cnvctmgdrag, cnvctdetmflx, duwt, duem, dusd, dudp - use vrbls2d, only: f, pd, fis, pblh, ustar, z0, ths, qs, twbs, qwbs, avgcprate, & - cprate, avgprec, prec, lspa, sno, si, cldefi, th10, q10, tshltr, pshltr, & - tshltr, albase, avgalbedo, avgtcdc, czen, czmean, mxsnal, radot, sigt4, & - cfrach, cfracl, cfracm, avgcfrach, qshltr, avgcfracl, avgcfracm, cnvcfr, & - islope, cmc, grnflx, vegfrc, acfrcv, ncfrcv, acfrst, ncfrst, ssroff, & - bgroff, rlwin, rlwtoa, cldwork, alwin, alwout, alwtoa, rswin, rswinc, & - rswout, aswin, auvbin, auvbinc, aswout, aswtoa, sfcshx, sfclhx, subshx, & - snopcx, sfcux, sfcvx, sfcuvx, gtaux, gtauy, potevp, u10, v10, smstav, & - smstot, ivgtyp, isltyp, sfcevp, sfcexc, acsnow, acsnom, sst, thz0, qz0, & - uz0, vz0, ptop, htop, pbot, hbot, ptopl, pbotl, ttopl, ptopm, pbotm, ttopm, & - ptoph, pboth, pblcfr, ttoph, runoff, maxtshltr, mintshltr, maxrhshltr, & - minrhshltr, dzice, smcwlt, suntime, fieldcapa, htopd, hbotd, htops, hbots, & - cuppt, dusmass, ducmass, dusmass25, ducmass25, aswintoa, & - u10h,v10h - use soil, only: sldpth, sh2o, smc, stc - use masks, only: lmv, lmh, htm, vtm, gdlat, gdlon, dx, dy, hbm2, sm, sice -! use kinds, only: i_llong - use nemsio_module, only: nemsio_gfile, nemsio_getfilehead, nemsio_getheadvar, nemsio_close - use physcons_post, only: grav => con_g, fv => con_fvirt, rgas => con_rd, & - eps => con_eps, epsm1 => con_epsm1 - use params_mod, only: erad, dtr, tfrz, h1, d608, rd, p1000, capa - use lookup_mod, only: thl, plq, ptbl, ttbl, rdq, rdth, rdp, rdthe, pl, qs0, sqs, sthe, & - ttblq, rdpq, rdtheq, stheq, the0q, the0 - use ctlblk_mod, only: me, mpi_comm_comp, icnt, idsp, jsta, jend, ihrst, idat, sdat, ifhr, & - ifmin, filename, tprec, tclod, trdlw, trdsw, tsrfc, tmaxmin, td3d, restrt, sdat, & - jend_m, imin, imp_physics, dt, spval, pdtop, pt, qmin, nbin_du, nphs, dtq2, ardlw,& - ardsw, asrfc, avrain, avcnvc, theat, gdsdegr, spl, lsm, alsl, im, jm, im_jm, lm, & - jsta_2l, jend_2u, nsoil, lp1, icu_physics, ivegsrc, novegtype, nbin_ss, nbin_bc, & - nbin_oc, nbin_su, gocart_on, pt_tbl, hyb_sigp - use gridspec_mod, only: maptype, gridtype, latstart, latlast, lonstart, lonlast, cenlon, & - dxval, dyval, truelat2, truelat1, psmapf, cenlat - use upp_physics, only: fpvsnew -! use wrf_io_flags_mod, only: ! Do we need this? -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none -! - type(nemsio_gfile),intent(inout) :: nfile,ffile,rfile -! -! INCLUDE/SET PARAMETERS. -! - INCLUDE "mpif.h" - -! integer,parameter:: MAXPTS=1000000 ! max im*jm points -! -! real,parameter:: con_g =9.80665e+0! gravity -! real,parameter:: con_rv =4.6150e+2 ! gas constant H2O -! real,parameter:: con_rd =2.8705e+2 ! gas constant air -! real,parameter:: con_fvirt =con_rv/con_rd-1. -! real,parameter:: con_eps =con_rd/con_rv -! real,parameter:: con_epsm1 =con_rd/con_rv-1 -! -! This version of INITPOST shows how to initialize, open, read from, and -! close a NetCDF dataset. In order to change it to read an internal (binary) -! dataset, do a global replacement of _ncd_ with _int_. - - real, parameter :: gravi = 1.0/grav - integer,intent(in) :: NREC,iostatusFlux,iostatusD3D,iostatusAER - character(len=20) :: VarName, VcoordName - integer :: Status - character startdate*19,SysDepInfo*80,cgar*1 - character startdate2(19)*4 -! -! NOTE: SOME INTEGER VARIABLES ARE READ INTO DUMMY ( A REAL ). THIS IS OK -! AS LONG AS REALS AND INTEGERS ARE THE SAME SIZE. -! -! ALSO, EXTRACT IS CALLED WITH DUMMY ( A REAL ) EVEN WHEN THE NUMBERS ARE -! INTEGERS - THIS IS OK AS LONG AS INTEGERS AND REALS ARE THE SAME SIZE. - LOGICAL RUNB,SINGLRST,SUBPOST,NEST,HYDRO,IOOMG,IOALL - logical, parameter :: debugprint = .false., zerout = .false. -! logical, parameter :: debugprint = .true., zerout = .false. - CHARACTER*32 LABEL - CHARACTER*40 CONTRL,FILALL,FILMST,FILTMP,FILTKE,FILUNV,FILCLD,FILRAD,FILSFC - CHARACTER*4 RESTHR - CHARACTER FNAME*255,ENVAR*50 - INTEGER IDATE(8),JDATE(8),JPDS(200),JGDS(200),KPDS(200),KGDS(200),IGDS(18) -! LOGICAL*1 LB(IM,JM) -! -! INCLUDE COMMON BLOCKS. -! -! DECLARE VARIABLES. -! -! REAL fhour - integer nfhour ! forecast hour from nems io file - REAL RINC(5) - - REAL DUMMY(IM,JM), DUMMY2(IM,JM) - real, allocatable :: fi(:,:,:) -!jw - integer ii,jj,js,je,iyear,imn,iday,itmp,ioutcount,istatus, & - I,J,L,ll,k,kf,irtn,igdout,n,Index,nframe, & - impf,jmpf,nframed2,iunitd3d,ierr,idum,iret - real TSTART,TLMH,TSPH,ES,FACT,soilayert,soilayerb,zhour,dum, & - tvll,pmll,tv - - character*8, allocatable :: recname(:) - character*16,allocatable :: reclevtyp(:) - integer, allocatable :: reclev(:) - real, allocatable :: glat1d(:), glon1d(:), qstl(:) - real, allocatable :: wrk1(:,:), wrk2(:,:) - real, allocatable :: p2d(:,:), t2d(:,:), q2d(:,:), & - qs2d(:,:), cw2d(:,:), cfr2d(:,:) - real(kind=4),allocatable :: vcoord4(:,:,:) - real, dimension(lm+1) :: ak5, bk5 - real*8, allocatable :: pm2d(:,:), pi2d(:,:) - - real buf(im,jsta_2l:jend_2u) - -! real buf(im,jsta_2l:jend_2u),bufsoil(im,nsoil,jsta_2l:jend_2u) & -! ,buf3d(im,jsta_2l:jend_2u,lm),buf3d2(im,lp1,jsta_2l:jend_2u) - - real LAT, isa, jsa -! REAL, PARAMETER :: QMIN = 1.E-15 - -! DATA BLANK/' '/ -! -!*********************************************************************** -! START INIT HERE. -! - WRITE(6,*)'INITPOST: ENTER INITPOST_GFS_NEMS' - WRITE(6,*)'me=',me,'LMV=',size(LMV,1),size(LMV,2),'LMH=', & - size(LMH,1),size(LMH,2),'jsta_2l=',jsta_2l,'jend_2u=', & - jend_2u,'im=',im -! - isa = im / 2 - jsa = (jsta+jend) / 2 - -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i=1,im - buf(i,j) = spval - enddo - enddo -! -! STEP 1. READ MODEL OUTPUT FILE -! -! -!*** -! -! LMH and LMV always = LM for sigma-type vert coord - -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i = 1, im - LMV(i,j) = lm - LMH(i,j) = lm - end do - end do - -! HTM VTM all 1 for sigma-type vert coord - -!$omp parallel do private(i,j,l) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - HTM (i,j,l) = 1.0 - VTM (i,j,l) = 1.0 - end do - end do - end do -! -! how do I get the filename? -! fileName = '/ptmp/wx20mb/wrfout_01_030500' -! DateStr = '2002-03-05_18:00:00' -! how do I get the filename? -! call ext_int_ioinit(SysDepInfo,Status) -! print*,'called ioinit', Status -! call ext_int_open_for_read( trim(fileName), 0, 0, " ", -! & DataHandle, Status) -! print*,'called open for read', Status -! if ( Status /= 0 ) then -! print*,'error opening ',fileName, ' Status = ', Status ; stop -! endif -! get date/time info -! this routine will get the next time from the file, not using it -! print *,'DateStr before calling ext_int_get_next_time=',DateStr -! call ext_int_get_next_time(DataHandle, DateStr, Status) -! print *,'DateStri,Status,DataHandle = ',DateStr,Status,DataHandle - -! The end j row is going to be jend_2u for all variables except for V. - - JS = JSTA_2L - JE = JEND_2U - -! get start date - if (me == 0)then - print*,'nrec=',nrec - allocate(recname(nrec),reclevtyp(nrec),reclev(nrec)) - allocate(glat1d(im*jm),glon1d(im*jm)) - allocate(vcoord4(lm+1,3,2)) - call nemsio_getfilehead(nfile,iret=iret & - ,idate=idate(1:7),nfhour=nfhour,recname=recname & - ,reclevtyp=reclevtyp,reclev=reclev,lat=glat1d & - ,lon=glon1d,nframe=nframe,vcoord=vcoord4) - if(iret/=0)print*,'error getting idate,nfhour' - print *,'latstar1=',glat1d(1),glat1d(im*jm) -! print *,'printing an inventory of GFS nemsio file' -! do i=1,nrec -! print *,'recname=',(trim(recname(i))) -! print *,'reclevtyp=',(trim(reclevtyp(i))) -! print *,'reclev=',(reclev(i)) -! end do -! deallocate (recname,reclevtyp,reclev) - -! call nemsio_getfilehead(ffile,nrec=idum) -! print*,'nrec for flux file = ',idum -! allocate(recname(idum),reclevtyp(idum),reclev(idum)) -! call nemsio_getfilehead(ffile,iret=iret, & -! recname=recname,reclevtyp=reclevtyp,reclev=reclev) -! do i=1,idum -! print *,'recname=',(trim(recname(i))) -! print *,'reclevtyp=',(trim(reclevtyp(i))) -! print *,'reclev=',(reclev(i)) -! end do - -!$omp parallel do private(i,j) - do j=1,jm - do i=1,im - dummy(i,j) = glat1d((j-1)*im+i) - dummy2(i,j) = glon1d((j-1)*im+i) - end do - end do -! - if (hyb_sigp) then - do l=1,lm+1 - ak5(l) = vcoord4(l,1,1) - bk5(l) = vcoord4(l,2,1) - enddo - endif -! - deallocate(recname,reclevtyp,reclev,glat1d,glon1d,vcoord4) -! can't get idate and fhour, specify them for now -! idate(4)=2006 -! idate(2)=9 -! idate(3)=16 -! idate(1)=0 -! fhour=6.0 - print*,'idate before broadcast = ',(idate(i),i=1,7) - end if - call mpi_bcast(idate(1), 7, MPI_INTEGER, 0, mpi_comm_comp, iret) - call mpi_bcast(nfhour, 1, MPI_INTEGER, 0, mpi_comm_comp, iret) - call mpi_bcast(nframe, 1, MPI_INTEGER, 0, mpi_comm_comp, iret) - print*,'idate after broadcast = ',(idate(i),i=1,4) - print*,'nfhour = ',nfhour - - if (hyb_sigp) then - call mpi_bcast(ak5, lm+1, MPI_REAL, 0, mpi_comm_comp, iret) - call mpi_bcast(bk5, lm+1, MPI_REAL, 0, mpi_comm_comp, iret) - endif - if (me == 0) print *,' ak5=',ak5 - if (me == 0) print *,' bk5=',bk5 - -! sample print point - ii = im/2 - jj = jm/2 - call mpi_scatterv(dummy(1,1),icnt,idsp,mpi_real & - ,gdlat(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,ierr) - call mpi_scatterv(dummy2(1,1),icnt,idsp,mpi_real & - ,gdlon(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,ierr) - - print *,'before call EXCH,mype=',me,'max(gdlat)=',maxval(gdlat), & - 'max(gdlon)=', maxval(gdlon) - CALL EXCH(gdlat(1,JSTA_2L)) - print *,'after call EXCH,mype=',me - -!$omp parallel do private(i,j) - do j = jsta, jend_m - do i = 1, im-1 - DX (i,j) = ERAD*COS(GDLAT(I,J)*DTR) *(GDLON(I+1,J)-GDLON(I,J))*DTR - DY (i,j) = ERAD*(GDLAT(I,J)-GDLAT(I,J+1))*DTR ! like A*DPH -! F(I,J)=1.454441e-4*sin(gdlat(i,j)*DTR) ! 2*omeg*sin(phi) -! if (i == ii .and. j == jj) print*,'sample LATLON, DY, DY=' & -! ,i,j,GDLAT(I,J),GDLON(I,J),DX(I,J),DY(I,J) - end do - end do - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - F(I,J) = 1.454441e-4*sin(gdlat(i,j)*DTR) ! 2*omeg*sin(phi) - end do - end do - - impf = im - jmpf = jm - print*,'impf,jmpf,nframe= ',impf,jmpf,nframe - -!MEB not sure how to get these - ! waiting to read in lat lon from GFS soon -! varname='GLAT' -! call retrieve_index(index,VarName,varname_all,nrecs,iret) -! if (iret /= 0) then -! print*,VarName," not found in file-Assigned missing values" -! GDLAT=SPVAL -! else -! this_offset=file_offset(index+1)+(jsta_2l-1)*4*im -! this_length=im*(jend_2u-jsta_2l+1) -! call mpi_file_read_at(iunit,this_offset -! + ,buf,this_length,mpi_real4 -! + , mpi_status_ignore, ierr) -! if (ierr /= 0) then -! print*,"Error reading ", VarName,"Assigned missing values" -! GDLAT=SPVAL -! else -! do j = jsta_2l, jend_2u -! do i = 1, im -! F(I,J)=1.454441e-4*sin(buf(I,J)) ! 2*omeg*sin(phi) -! GDLAT(I,J)=buf(I,J)*RTD - -! enddo -! enddo -! end if -! end if - -! varname='GLON' -! call retrieve_index(index,VarName,varname_all,nrecs,iret) -! if (iret /= 0) then -! print*,VarName," not found in file-Assigned missing values" -! GDLON=SPVAL -! else -! this_offset=file_offset(index+1)+(jsta_2l-1)*4*im -! this_length=im*(jend_2u-jsta_2l+1) -! call mpi_file_read_at(iunit,this_offset -! + ,buf,this_length,mpi_real4 -! + , mpi_status_ignore, ierr) -! if (ierr /= 0) then -! print*,"Error reading ", VarName,"Assigned missing values" -! GDLON=SPVAL -! else -! do j = jsta_2l, jend_2u -! do i = 1, im -! GDLON(I,J)=buf(I,J)*RTD -! if(i == 409.and.j == 835)print*,'GDLAT GDLON in INITPOST=' -! + ,i,j,GDLAT(I,J),GDLON(I,J) -! enddo -! enddo -! end if -! end if - -! if(jsta<=594.and.jend>=594)print*,'gdlon(120,594)= ', -! + gdlon(120,594) - - -! iyear=idate(4)+2000 ! older gfsio only has 2 digit year - iyear = idate(1) - imn = idate(2) ! ask Jun - iday = idate(3) ! ask Jun - ihrst = idate(4) - imin = idate(5) - jdate = 0 - idate = 0 -! -! read(startdate,15)iyear,imn,iday,ihrst,imin - 15 format(i4,1x,i2,1x,i2,1x,i2,1x,i2) - print*,'start yr mo day hr min =',iyear,imn,iday,ihrst,imin - print*,'processing yr mo day hr min=' & - ,idat(3),idat(1),idat(2),idat(4),idat(5) -! - idate(1) = iyear - idate(2) = imn - idate(3) = iday - idate(5) = ihrst - idate(6) = imin - SDAT(1) = imn - SDAT(2) = iday - SDAT(3) = iyear - jdate(1) = idat(3) - jdate(2) = idat(1) - jdate(3) = idat(2) - jdate(5) = idat(4) - jdate(6) = idat(5) -! - print *,' idate=',idate - print *,' jdate=',jdate -! CALL W3DIFDAT(JDATE,IDATE,2,RINC) -! ifhr=nint(rinc(2)) -! - CALL W3DIFDAT(JDATE,IDATE,0,RINC) -! - print *,' rinc=',rinc - ifhr = nint(rinc(2)+rinc(1)*24.) - print *,' ifhr=',ifhr - ifmin = nint(rinc(3)) -! if(ifhr /= nint(fhour))print*,'find wrong Grib file';stop - print*,' in INITPOST ifhr ifmin fileName=',ifhr,ifmin,fileName - -! GFS has the same accumulation bucket for precipitation and fluxes and it is written to header -! the header has the start hour information so post uses it to recontruct bucket - if(me==0)then - call nemsio_getheadvar(ffile,'zhour',zhour,iret=iret) - if(iret==0)then - tprec = 1.0*ifhr-zhour - tclod = tprec - trdlw = tprec - trdsw = tprec - tsrfc = tprec - tmaxmin = tprec - td3d = tprec - print*,'tprec from flux file header= ',tprec - else - print*,'Error reading accumulation bucket from flux file', & - 'header - will try to read from env variable FHZER' - CALL GETENV('FHZER',ENVAR) - read(ENVAR, '(I2)')idum - tprec = idum*1.0 - tclod = tprec - trdlw = tprec - trdsw = tprec - tsrfc = tprec - tmaxmin = tprec - td3d = tprec - print*,'TPREC from FHZER= ',tprec - end if - end if - - call mpi_bcast(tprec, 1,MPI_REAL,0,mpi_comm_comp,iret) - call mpi_bcast(tclod, 1,MPI_REAL,0,mpi_comm_comp,iret) - call mpi_bcast(trdlw, 1,MPI_REAL,0,mpi_comm_comp,iret) - call mpi_bcast(trdsw, 1,MPI_REAL,0,mpi_comm_comp,iret) - call mpi_bcast(tsrfc, 1,MPI_REAL,0,mpi_comm_comp,iret) - call mpi_bcast(tmaxmin,1,MPI_REAL,0,mpi_comm_comp,iret) - call mpi_bcast(td3d, 1,MPI_REAL,0,mpi_comm_comp,iret) - -! Getting tstart - tstart=0. -! VarName='TSTART' -! call retrieve_index(index,VarName,varname_all,nrecs,iret) -! if (iret /= 0) then -! print*,VarName," not found in file" -! else -! call mpi_file_read_at(iunit,file_offset(index)+5*4 -! + ,garb,1,mpi_real4 -! + , mpi_status_ignore, ierr) -! if (ierr /= 0) then -! print*,"Error reading ", VarName," using MPIIO" -! else -! print*,VarName, ' from MPIIO READ= ',garb -! tstart=garb -! end if -! end if - print*,'tstart= ',tstart - -! Getiing restart - - RESTRT=.TRUE. ! set RESTRT as default -! call ext_int_get_dom_ti_integer(DataHandle,'RESTARTBIN',itmp -! + ,1,ioutcount,istatus) - -! IF(itmp < 1)THEN -! RESTRT=.FALSE. -! ELSE -! RESTRT=.TRUE. -! END IF - -! print*,'status for getting RESTARTBIN= ',istatus - -! print*,'Is this a restrt run? ',RESTRT - - IF(tstart > 1.0E-2)THEN - ifhr = ifhr+NINT(tstart) - rinc = 0 - idate = 0 - rinc(2) = -1.0*ifhr - call w3movdat(rinc,jdate,idate) - SDAT(1) = idate(2) - SDAT(2) = idate(3) - SDAT(3) = idate(1) - IHRST = idate(5) - print*,'new forecast hours for restrt run= ',ifhr - print*,'new start yr mo day hr min =',sdat(3),sdat(1) & - ,sdat(2),ihrst,imin - END IF - - imp_physics = 99 !set GFS mp physics to 99 for Zhao scheme - print*,'MP_PHYSICS= ',imp_physics - -! Initializes constants for Ferrier microphysics - if(imp_physics==5 .or. imp_physics==85 .or. imp_physics==95)then - CALL MICROINIT(imp_physics) - end if - -! IVEGSRC=1 for IGBP, 0 for USGS, 2 for UMD - VarName='IVEGSRC' - if(me == 0)then - call nemsio_getheadvar(nfile,trim(VarName),IVEGSRC,iret) - if (iret /= 0) then - print*,VarName,' not found in file-Assigned 2 for UMD as default' - IVEGSRC=1 - end if - end if - call mpi_bcast(IVEGSRC,1,MPI_INTEGER,0,mpi_comm_comp,iret) - print*,'IVEGSRC= ',IVEGSRC - -! set novegtype based on vegetation classification - if(ivegsrc==2)then - novegtype=13 - else if(ivegsrc==1)then - novegtype=20 - else if(ivegsrc==0)then - novegtype=24 - end if - print*,'novegtype= ',novegtype - - VarName='CU_PHYSICS' - if(me == 0)then - call nemsio_getheadvar(nfile,trim(VarName),iCU_PHYSICS,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned 4 for SAS as default" - iCU_PHYSICS=4 - end if - end if - call mpi_bcast(iCU_PHYSICS,1,MPI_INTEGER,0,mpi_comm_comp,iret) - if (me == 0) print*,'CU_PHYSICS= ',iCU_PHYSICS -! waiting to retrieve lat lon infor from raw GFS output -! VarName='DX' - -! VarName='DY' - -! GFS does not need DT to compute accumulated fields, set it to one -! VarName='DT' - DT=1 -! GFS does not need truelat -! VarName='TRUELAT1' - -! VarName='TRUELAT2' - -! Specigy maptype=4 for Gaussian grid -! maptype=4 -! write(6,*) 'maptype is ', maptype -! HBM2 is most likely not in Grib message, set them to ones - HBM2=1.0 - -! try to get kgds from flux grib file and then convert to igds that is used by GRIBIT.f -! flux files are now nemsio files so comment the following lines out -! if(me == 0)then -! jpds=-1.0 -! jgds=-1.0 -! igds=0 -! call getgb(iunit,0,im_jm,0,jpds,jgds,kf & -! ,k,kpds,kgds,lb,dummy,ierr) -! if(ierr == 0)then -! call R63W72(KPDS,KGDS,JPDS,IGDS(1:18)) -! print*,'in INITPOST_GFS,IGDS for GFS= ',(IGDS(I),I=1,18) -! end if -! end if -! call mpi_bcast(igds(1),18,MPI_INTEGER,0,mpi_comm_comp,iret) -! print*,'IGDS for GFS= ',(IGDS(I),I=1,18) - -! Specigy grid type -! if(iostatusFlux==0)then - if(IGDS(4)/=0)then - maptype=IGDS(3) - else if((im/2+1)==jm)then - maptype=0 !latlon grid - else - maptype=4 ! default gaussian grid - end if - gridtype='A' - - if (me == 0) write(6,*) 'maptype and gridtype is ', maptype,gridtype - -! start retrieving data using gfsio, first land/sea mask - -! VarName='land' -! VcoordName='sfc' -! l=1 - -! if(me == 0)then -! call gfsio_readrecvw34(gfile,trim(VarName),trim(VcoordName) -! + ,l,dummy,iret=iret) -! if (iret /= 0) then -! print*,VarName," not found in file-Assigned missing values" -! dummy=spval -! else -! -! do j = 1, jm -! do i = 1, im -! dummy(I,J)=1.0 - dummy(I,J) ! convert Grib message to 2D -! if (j == jm/2 .and. mod(i,10) == 0) -! + print*,'sample ',VarName, ' = ',i,j,dummy(i,j) -! -! enddo -! enddo -! end if -! end if -! -! call mpi_scatterv(dummy,icnt,idsp,mpi_real -! + ,sm(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,iret) -! if (iret /= 0)print*,'Error scattering array';stop - - VcoordName='sfc' ! surface fileds - l=1 - -! start retrieving data using getgb, first land/sea mask - VarName='land' - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,impf,jmpf,nframe,sm) - -! where(sm /= spval)sm=1.0-sm ! convert to sea mask -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= spval) sm(i,j) = 1.0 - sm(i,j) - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',sm(isa,jsa) - - -! sea ice mask using getgb - - VarName='icec' - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,sice) - -! if(debugprint)print*,'sample ',VarName,' = ',sice(isa,jsa) - -! where(sice /=spval .and. sice >=1.0)sm=0.0 !sea ice has sea mask=0 -! GFS flux files have land points with non-zero sea ice, per Iredell, these -! points have sea ice changed to zero, i.e., trust land mask more than sea ice -! where(sm/=spval .and. sm==0.0)sice=0.0 !specify sea ice=0 at land - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= spval .and. sm(i,j) == 0.0) sice(i,j) = 0.0 - enddo - enddo - -! Terrain height * G using nemsio - VarName='hgt' - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,fis) - -! where(fis /= spval)fis=fis*grav - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (fis(i,j) /= spval) then - zint(i,j,lp1) = fis(i,j) - fis(i,j) = fis(i,j) * grav - - endif - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',fis(isa,jsa) - -! Surface pressure using nemsio - VarName='pres' - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,pint(1,jsta_2l,lp1)) - -! if(debugprint)print*,'sample surface pressure = ',pint(isa,jsa,lp1 - -! -! vertical loop for Layer 3d fields -! -------------------------------- - VcoordName = 'mid layer' - - do l=1,lm - ll=lm-l+1 - -! model level T - print*,'start retrieving GFS T using nemsio' - VarName='tmp' - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,t(1,jsta_2l,ll)) - -! if(debugprint)print*,'sample ',ll,VarName,' = ',ll,t(isa,jsa,ll) - -! model level q - VarName='spfh' - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,q(1,jsta_2l,ll)) -! if(debugprint)print*,'sample ',ll,VarName,' = ',ll,q(isa,jsa,ll) - -! i model level u - VarName='ugrd' - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,uh(1,jsta_2l,ll)) -! if(debugprint)print*,'sample ',ll,VarName,' = ',ll,uh(isa,jsa,ll) - -! model level v - VarName='vgrd' - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,vh(1,jsta_2l,ll)) -! if(debugprint)print*,'sample ',ll,VarName,' = ',ll,vh(isa,jsa,ll) - -! model level pressure - if (.not. hyb_sigp) then - VarName='pres' - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,pmid(1,jsta_2l,ll)) -! if(debugprint)print*,'sample ',ll,VarName,' = ',ll,pmid(isa,jsa,ll) - -! GFS is on A grid and does not need PMIDV - -! dp - VarName='dpres' -! write(0,*)' bef getnemsandscatter ll=',ll,' l=',l,VarName - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,dpres(1,jsta_2l,ll)) -! if(debugprint)print*,'sample ',ll,VarName,' = ',ll,pmid(isa,jsa,ll) - endif -! ozone mixing ratio - VarName='o3mr' - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,o3(1,jsta_2l,ll)) - -! if(debugprint)print*,'sample ',ll,VarName,' = ',ll,o3(isa,jsa,ll) -! write(1000+me,*)'sample ',ll,VarName,' = ',ll,o3(isa,jsa,ll) - -! cloud water and ice mixing ratio for zhao scheme -! need to look up old eta post to derive cloud water/ice from cwm -! Zhao scheme does not produce suspended rain and snow - -!$omp parallel do private(i,j) - do j = jsta, jend - do i=1,im - qqw(i,j,ll) = 0. - qqr(i,j,ll) = 0. - qqs(i,j,ll) = 0. - qqi(i,j,ll) = 0. - enddo - enddo - - VarName='clwmr' - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,cwm(1,jsta_2l,ll)) -! if(debugprint)print*,'sample ',ll,VarName,' = ',ll,cwm(isa,jsa,ll) - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if(t(i,j,ll) < (TFRZ-15.) )then ! dividing cloud water from ice - qqi(i,j,ll) = cwm(i,j,ll) - else - qqw(i,j,ll) = cwm(i,j,ll) - end if -! if (j == jm/2 .and. mod(i,50) == 0) -! + print*,'sample ',trim(VarName), ' after scatter= ' -! + ,i,j,ll,cwm(i,j,ll) - end do - end do -! if (iret /= 0)print*,'Error scattering array';stop - -! pressure vertical velocity - VarName='vvel' - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,omga(1,jsta_2l,ll)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,omga(isa,jsa,ll) - -! With SHOC NEMS/GSM does output TKE now - VarName='tke' - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,q2(1,jsta_2l,ll)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,q2(isa,jsa,ll) - - - end do ! do loop for l - -! construct interface pressure from model top (which is zero) and dp from top down PDTOP -! pdtop = spval - pt = 0. -! pd = spval ! GFS does not output PD - - ii = im/2 - jj = (jsta+jend)/2 - -!!!!! COMPUTE Z, GFS integrates Z on mid-layer instead -!!! use GFS contants to see if height becomes more aggreable to GFS pressure grib file - if (hyb_sigp) then - do l=lm,1,-1 -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - pint(i,j,l) = ak5(lm+2-l) + bk5(lm+2-l)*pint(i,j,lp1) - pmid(i,j,l) = 0.5*(pint(i,j,l)+pint(i,j,l+1)) ! for now - Moorthi - enddo - enddo - if (me == 0) print*,'sample pint,pmid' ,ii,jj,l,pint(ii,jj,l),pmid(ii,jj,l) - enddo - else - do l=2,lm -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - pint(i,j,l) = pint(i,j,l-1) + dpres(i,j,l-1) - enddo - enddo - if (me == 0) print*,'sample pint,pmid' ,ii,jj,l,pint(ii,jj,l),pmid(ii,jj,l) - end do - endif - - allocate(wrk1(im,jsta:jend),wrk2(im,jsta:jend)) - allocate(fi(im,jsta:jend,2)) - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - pd(i,j) = spval ! GFS does not output PD - pint(i,j,1) = PT - alpint(i,j,lp1) = log(pint(i,j,lp1)) - wrk1(i,j) = log(PMID(I,J,LM)) - wrk2(i,j) = T(I,J,LM)*(Q(I,J,LM)*fv+1.0) - FI(I,J,1) = FIS(I,J) & - + wrk2(i,j)*rgas*(ALPINT(I,J,Lp1)-wrk1(i,j)) - ZMID(I,J,LM) = FI(I,J,1) * gravi - end do - end do - - print *,' Tprof=',t(ii,jj,:) - print *,' Qprof=',q(ii,jj,:) - -! SECOND, INTEGRATE HEIGHT HYDROSTATICLY, GFS integrate height on mid-layer - - DO L=LM,2,-1 ! omit computing model top height because it's infinity - ll = l - 1 -! write(0,*)' me=',me,'ll=',ll,' gravi=',gravi,rgas,' fv=',fv -!$omp parallel do private(i,j,tvll,pmll,fact) - do j = jsta, jend -! write(0,*)' j=',j,' me=',me - do i = 1, im - alpint(i,j,l) = log(pint(i,j,l)) - tvll = T(I,J,LL)*(Q(I,J,LL)*fv+1.0) - pmll = log(PMID(I,J,LL)) - -! if (me == 0 .and. i == ii .and. j == jj ) print*,'L ZINT= ',l,' tvll =', tvll, & -! ' pmll=',pmll,' wrk2=',wrk2(i,j),' wrk1=',wrk1(i,j),' fi1=',fi(i,j,1), & -! ' T=',T(i,j,LL),' Q=',Q(i,j,ll) - - FI(I,J,2) = FI(I,J,1) + (0.5*rgas)*(wrk2(i,j)+tvll) & - * (wrk1(i,j)-pmll) - ZMID(I,J,LL) = FI(I,J,2) * gravi -! - FACT = (ALPINT(I,J,L)-wrk1(i,j)) / (pmll-wrk1(i,j)) - ZINT(I,J,L) = ZMID(I,J,L) + (ZMID(I,J,LL)-ZMID(I,J,L)) * FACT - FI(I,J,1) = FI(I,J,2) - wrk1(i,J) = pmll - wrk2(i,j) = tvll -! if (me == 0 .and. i == ii .and. j == jj ) print*,'L ZINT= ',l,zint(ii,jj,l), & -! 'alpint=',ALPINT(ii,jj,l),'pmid=',LOG(PMID(Ii,Jj,L)),'pmid(l-1)=', & -! LOG(PMID(Ii,Jj,L-1)),'zmd=',ZMID(Ii,Jj,L),'zmid(l-1)=',ZMID(Ii,Jj,L-1) - ENDDO - ENDDO - - if (me == 0) print*,'L ZINT= ',l,zint(ii,jj,l), & - 'alpint=',ALPINT(ii,jj,l),'pmid=',LOG(PMID(Ii,Jj,L)),'pmid(l-1)=', & - LOG(PMID(Ii,Jj,L-1)),'zmd=',ZMID(Ii,Jj,L),'zmid(l-1)=',ZMID(Ii,Jj,L-1) - ENDDO - deallocate(wrk1,wrk2,fi) - - - if (gocart_on) then - -! GFS output dust in nemsio (GOCART) - do n=1,nbin_du - do l=1,lm -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - dust(i,j,l,n) = spval - enddo - enddo - enddo - enddo -! DUST = SPVAL - VarName='du001' - VcoordName='mid layer' - do l=1,lm - ll=lm-l+1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,dust(1,jsta_2l,ll,1)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,dust(isa,jsa,ll,1) - end do ! do loop for l - - VarName='du002' - VcoordName='mid layer' - do l=1,lm - ll=lm-l+1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,dust(1,jsta_2l,ll,2)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,dust(isa,jsa,ll,2) - end do ! do loop for l - - VarName='du003' - VcoordName='mid layer' - do l=1,lm - ll=lm-l+1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,dust(1,jsta_2l,ll,3)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,dust(isa,jsa,ll,3) - end do ! do loop for l - - VarName='du004' - VcoordName='mid layer' - do l=1,lm - ll=lm-l+1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,dust(1,jsta_2l,ll,4)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,dust(isa,jsa,ll,4) - end do ! do loop for l - - VarName='du005' - VcoordName='mid layer' - do l=1,lm - ll=lm-l+1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,dust(1,jsta_2l,ll,5)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,dust(isa,jsa,ll,5) - end do ! do loop for l -! -! GFS output sea salt in nemsio (GOCART) - do n=1,nbin_ss - do l=1,lm -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - salt(i,j,l,n) = spval - enddo - enddo - enddo - enddo -! SALT = SPVAL - VarName='ss001' - VcoordName='mid layer' - do l=1,lm - ll=lm-l+1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,salt(1,jsta_2l,ll,1)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,salt(isa,jsa,ll,1) - end do ! do loop for l - - VarName='ss002' - VcoordName='mid layer' - do l=1,lm - ll=lm-l+1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,salt(1,jsta_2l,ll,2)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,salt(isa,jsa,ll,2) - end do ! do loop for l - - VarName='ss003' - VcoordName='mid layer' - do l=1,lm - ll=lm-l+1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,salt(1,jsta_2l,ll,3)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,salt(isa,jsa,ll,3) - end do ! do loop for l - - VarName='ss004' - VcoordName='mid layer' - do l=1,lm - ll=lm-l+1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,salt(1,jsta_2l,ll,4)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,salt(isa,jsa,ll,4) - end do ! do loop for l - - VarName='ss005' - VcoordName='mid layer' - do l=1,lm - ll=lm-l+1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,salt(1,jsta_2l,ll,5)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,salt(isa,jsa,ll,5) - end do ! do loop for l - -! GFS output black carbon in nemsio (GOCART) - do n=1,nbin_oc - do l=1,lm -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - soot(i,j,l,n) = spval - enddo - enddo - enddo - enddo -! SOOT = SPVAL - VarName='bcphobic' - VcoordName='mid layer' - do l=1,lm - ll=lm-l+1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,soot(1,jsta_2l,ll,1)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,soot(isa,jsa,ll,1) - end do ! do loop for l - - VarName='bcphilic' - VcoordName='mid layer' - do l=1,lm - ll=lm-l+1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,soot(1,jsta_2l,ll,2)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,soot(isa,jsa,ll,2) - end do ! do loop for l - -! GFS output organic carbon in nemsio (GOCART) - do n=1,nbin_oc - do l=1,lm -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - waso(i,j,l,n) = spval - enddo - enddo - enddo - enddo -! WASO = SPVAL - VarName='ocphobic' - VcoordName='mid layer' - do l=1,lm - ll=lm-l+1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,waso(1,jsta_2l,ll,1)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,waso(isa,jsa,ll,1) - end do ! do loop for l - - VarName='ocphilic' - VcoordName='mid layer' - do l=1,lm - ll=lm-l+1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,waso(1,jsta_2l,ll,2)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,waso(isa,jsa,ll,2) - end do ! do loop for l - -! GFS output sulfate in nemsio (GOCART) - do n=1,nbin_su - do l=1,lm -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - suso(i,j,l,n) = spval - enddo - enddo - enddo - enddo -! SUSO = SPVAL - VarName='so4' - VcoordName='mid layer' - do l=1,lm - ll=lm-l+1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,suso(1,jsta_2l,ll,1)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,suso(isa,jsa,ll,1) - end do ! do loop for l - - -! -- compute air density RHOMID and remove negative tracer values - do l=1,lm -!$omp parallel do private(i,j,n,tv) - do j=jsta,jend - do i=1,im - - TV = T(I,J,L) * (H1+D608*MAX(Q(I,J,L),QMIN)) - RHOMID(I,J,L) = PMID(I,J,L) / (RD*TV) - do n = 1, NBIN_DU - IF ( dust(i,j,l,n) < SPVAL) THEN - DUST(i,j,l,n) = MAX(DUST(i,j,l,n), 0.0) - ENDIF - enddo - do n = 1, NBIN_SS - IF ( salt(i,j,l,n) < SPVAL) THEN - SALT(i,j,l,n) = MAX(SALT(i,j,l,n), 0.0) - ENDIF - enddo - do n = 1, NBIN_OC - IF ( waso(i,j,l,n) < SPVAL) THEN - WASO(i,j,l,n) = MAX(WASO(i,j,l,n), 0.0) - ENDIF - enddo - do n = 1, NBIN_BC - IF ( soot(i,j,l,n) < SPVAL) THEN - SOOT(i,j,l,n) = MAX(SOOT(i,j,l,n), 0.0) - ENDIF - enddo - do n = 1, NBIN_SU - IF ( suso(i,j,l,n) < SPVAL) THEN - SUSO(i,j,l,n) = MAX(SUSO(i,j,l,n), 0.0) - ENDIF - enddo - - end do - end do - end do - endif ! endif for gocart_on -! - -! PBL height using nemsio - VarName='hpbl' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,pblh) -! if(debugprint)print*,'sample ',VarName,' = ',pblh(isa,jsa) - -! frictional velocity using nemsio - VarName='fricv' -! VcoordName='sfc' -! l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,ustar) -! if(debugprint)print*,'sample ',VarName,' = ',ustar(isa,jsa) - -! roughness length using getgb - VarName='sfcr' -! VcoordName='sfc' -! l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,z0) -! if(debugprint)print*,'sample ',VarName,' = ',z0(isa,jsa) - -! surface potential T using getgb - VarName='tmp' -! VcoordName='sfc' -! l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,ths) - -! where(ths/=spval)ths=ths*(p1000/pint(:,:,lp1))**CAPA ! convert to THS - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (ths(i,j) /= spval) then -! write(0,*)' i=',i,' j=',j,' ths=',ths(i,j),' pint=',pint(i,j,lp1) - ths(i,j) = ths(i,j) * (p1000/pint(i,j,lp1))**capa - endif - QS(i,j) = SPVAL ! GFS does not have surface specific humidity - twbs(i,j) = SPVAL ! GFS does not have inst sensible heat flux - qwbs(i,j) = SPVAL ! GFS does not have inst latent heat flux - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',ths(isa,jsa) - - -! GFS does not have time step and physics time step, make up ones since they -! are not really used anyway - NPHS=2. - DT=80. - DTQ2 = DT * NPHS !MEB need to get physics DT - TSPH = 3600./DT !MEB need to get DT -! All GFS time-averaged quantities are in 6 hour bucket -! TPREC=6.0 - -! convective precip in m per physics time step using gfsio -! VarName='cprat' -! VcoordName='sfc' -! l=1 -! if(me == 0)then -! call gfsio_readrecvw34(gfile,trim(VarName),trim(VcoordName) & -! + ,l,dummy,iret=iret) -! if (iret /= 0) then -! print*,VarName," not found in file-Assigned missing values" -! dummy=spval -! else -! do j = 1, jm -! do i = 1, im -! dummy(I,J)= dummy(i,j)*dtq2/1000. ! convert to m -! if (j == jm/2 .and. mod(i,50) == 0) -! + print*,'sample ',VarName, ' = ',i,j,dummy(i,j) -! enddo -! enddo -! end if -! end if -! call mpi_scatterv(dummy,icnt,idsp,mpi_real & -! + , avgcprate(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,iret) -! if (iret /= 0)print*,'Error scattering array';stop - -! convective precip in m per physics time step using getgb - VarName='cprat' -! VcoordName='sfc' -! l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,avgcprate) -! where(avgcprate /= spval)avgcprate=avgcprate*dtq2/1000. ! convert to m -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgcprate(i,j) /= spval) avgcprate(i,j) = avgcprate(i,j) * (dtq2*0.001) - cprate(i,j) = avgcprate(i,j) - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',avgcprate(isa,jsa) - -! print*,'maxval CPRATE: ', maxval(CPRATE) - -! precip rate in m per physics time step using getgb - VarName='prate' -! VcoordName='sfc' -! l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,avgprec) -! where(avgprec /= spval)avgprec=avgprec*dtq2/1000. ! convert to m -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgprec(i,j) /= spval) avgprec(i,j) = avgprec(i,j) * (dtq2*0.001) - enddo - enddo - -! if(debugprint)print*,'sample ',VarName,' = ',avgprec(isa,jsa) - - prec=avgprec !set avg cprate to inst one to derive other fields - -! GFS does not have accumulated total, gridscale, and convective precip, will use inst precip to derive in SURFCE.f - - -! inst snow water eqivalent using nemsio - VarName='weasd' -! VcoordName='sfc' -! l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,sno) -! if(debugprint)print*,'sample ',VarName,' = ',sno(isa,jsa) - -! snow depth in mm using nemsio - VarName='snod' -! VcoordName='sfc' -! l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,si) -! where(si /= spval)si=si*1000. ! convert to mm -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (si(i,j) /= spval) si(i,j) = si(i,j) * 1000.0 - CLDEFI(i,j) = SPVAL ! GFS does not have convective cloud efficiency - lspa(i,j) = spval ! GFS does not have similated precip - TH10(i,j) = SPVAL ! GFS does not have 10 m theta - TH10(i,j) = SPVAL ! GFS does not have 10 m theta - Q10(i,j) = SPVAL ! GFS does not have 10 m humidity - ALBASE(i,j) = SPVAL ! GFS does not have snow free albedo - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',si(isa,jsa) - -!!$omp parallel do private(i,j,l) -! do l=1,lm -! do j=jsta,jend -! do i=1,im -! Q2(i,j,l) = SPVAL ! GFS does not have TKE because it uses MRF scheme -! ! GFS does not have surface exchange coeff -! enddo -! enddo -! enddo - -! 2m T using nemsio - VarName='tmp' - VcoordName='2 m above gnd' -! l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,tshltr) -! if(debugprint)print*,'sample ',VarName,' = ',tshltr(isa,jsa) - -! GFS does not have 2m pres, estimate it, also convert t to theta - Do j=jsta,jend - Do i=1,im - PSHLTR(I,J)=pint(I,J,lm+1)*EXP(-0.068283/tshltr(i,j)) - tshltr(i,j)= tshltr(i,j)*(p1000/PSHLTR(I,J))**CAPA ! convert to theta -! if (j == jm/2 .and. mod(i,50) == 0) -! + print*,'sample 2m T and P after scatter= ' -! + ,i,j,tshltr(i,j),pshltr(i,j) - end do - end do - -! 2m specific humidity using gfsio -! VarName='spfh' -! VcoordName='2m above gnc' -! l=1 -! if(me == 0)then -! call gfsio_readrecvw34(gfile,trim(VarName),trim(VcoordName) & -! + ,l,dummy,iret=iret) -! if (iret /= 0) then -! print*,VarName," not found in file-Assigned missing values" -! dummy=spval -! end if -! end if -! call mpi_scatterv(dummy,icnt,idsp,mpi_real & -! + ,qshltr(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,iret) -! if (iret /= 0)print*,'Error scattering array';stop - -! 2m specific humidity using nemsio - VarName='spfh' - VcoordName='2 m above gnd' -! l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,qshltr) -! if(debugprint)print*,'sample ',VarName,' = ',qshltr(isa,jsa) - - -! mid day avg albedo in fraction using gfsio -! VarName='albdo' -! VcoordName='sfc' -! l=1 -! if(me == 0)then -! call gfsio_readrecvw34(gfile,trim(VarName),trim(VcoordName) & -! + ,l,dummy,iret=iret) -! if (iret /= 0) then -! print*,VarName," not found in file-Assigned missing values" -! dummy=spval -! else -! do j = 1, jm -! do i = 1, im -! dummy(I,J)= dummy(i,j)/100. ! convert to fraction -! if (j == jm/2 .and. mod(i,50) == 0) -! + print*,'sample ',VarName, ' = ',i,j,dummy(i,j) -! enddo -! enddo -! end if -! end if -! call mpi_scatterv(dummy,icnt,idsp,mpi_real & -! + ,avgalbedo(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,iret) -! if (iret /= 0)print*,'Error scattering array';stop - -! mid day avg albedo in fraction using nemsio - VarName='albdo' - VcoordName='sfc' -! l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,avgalbedo) -! where(avgalbedo /= spval)avgalbedo=avgalbedo/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgalbedo(i,j) /= spval) avgalbedo(i,j) = avgalbedo(i,j) * 0.01 - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',avgalbedo(isa,jsa) - -! time averaged column cloud fractionusing nemsio - VarName='tcdc' - VcoordName='atmos col' -! l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,avgtcdc) -! where(avgtcdc /= spval)avgtcdc=avgtcdc/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgtcdc(i,j) /= spval) avgtcdc(i,j) = avgtcdc(i,j) * 0.01 - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',avgtcdc(isa,jsa) - -! GFS probably does not use zenith angle -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - Czen(i,j) = spval - CZMEAN(i,j) = SPVAL - enddo - enddo - -! maximum snow albedo in fraction using nemsio - VarName='mxsalb' - VcoordName='sfc' -! l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,mxsnal) -! where(mxsnal /= spval)mxsnal=mxsnal/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (mxsnal(i,j) /= spval) mxsnal(i,j) = mxsnal(i,j) * 0.01 - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',mxsnal(isa,jsa) - -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - radot(i,j) = spval ! GFS does not have inst surface outgoing longwave - enddo - enddo - -! GFS probably does not use sigt4, set it to sig*t^4 -!$omp parallel do private(i,j,tlmh) - Do j=jsta,jend - Do i=1,im - TLMH = T(I,J,LM) * T(I,J,LM) - Sigt4(i,j) = 5.67E-8 * TLMH * TLMH - End do - End do - -! TG is not used, skip it for now - -! will retrive f_ice when GFS switches to Ferrier scheme -! varname='F_ICE' -! call retrieve_index(index,VarName,varname_all,nrecs,iret) -! if (iret /= 0) then -! print*,VarName," not found in file-Assigned missing values" -! F_ice=SPVAL -! else -! this_offset=file_offset(index+1)+(jsta_2l-1)*4*im*lm -! this_length=im*(jend_2u-jsta_2l+1)*lm -! call mpi_file_read_at(iunit,this_offset -! + ,buf3d,this_length,mpi_real4 -! + , mpi_status_ignore, ierr) -! if (ierr /= 0) then -! print*,"Error reading ", VarName,"Assigned missing values" -! F_ice=SPVAL -! else -! do l = 1, lm -! ll=lm-l+1 -! do j = jsta_2l, jend_2u -! do i = 1, im -! F_ice( i, j, l ) = buf3d ( i, ll, j ) -! if(i == im/2.and.j == (jsta+jend)/2)print*,'sample F_ice= ', -! + i,j,l,F_ice( i, j, l ) -! end do -! end do -! end do -! end if -! end if - -! varname='F_RAIN' -! call retrieve_index(index,VarName,varname_all,nrecs,iret) -! if (iret /= 0) then -! print*,VarName," not found in file-Assigned missing values" -! F_rain=SPVAL -! else -! this_offset=file_offset(index+1)+(jsta_2l-1)*4*im*lm -! this_length=im*(jend_2u-jsta_2l+1)*lm -! call mpi_file_read_at(iunit,this_offset -! + ,buf3d,this_length,mpi_real4 -! + , mpi_status_ignore, ierr) -! if (ierr /= 0) then -! print*,"Error reading ", VarName,"Assigned missing values" -! F_rain=SPVAL -! else -! do l = 1, lm -! ll=lm-l+1 -! do j = jsta_2l, jend_2u -! do i = 1, im -! F_rain( i, j, l ) = buf3d ( i, ll, j ) -! if(i == im/2.and.j == (jsta+jend)/2)print*,'sample F_rain= ', -! + i,j,l,F_rain( i, j, l ) -! end do -! end do -! end do -! end if -! end if - -! varname='F_RIMEF' -! call retrieve_index(index,VarName,varname_all,nrecs,iret) -! if (iret /= 0) then -! print*,VarName," not found in file-Assigned missing values" -! F_RimeF=SPVAL -! else -! this_offset=file_offset(index+1)+(jsta_2l-1)*4*im*lm -! this_length=im*(jend_2u-jsta_2l+1)*lm -! call mpi_file_read_at(iunit,this_offset -! + ,buf3d,this_length,mpi_real4 -! + , mpi_status_ignore, ierr) -! if (ierr /= 0) then -! print*,"Error reading ", VarName,"Assigned missing values" -! F_RimeF=SPVAL -! else -! do l = 1, lm -! ll=lm-l+1 -! do j = jsta_2l, jend_2u -! do i = 1, im -! F_RimeF( i, j, l ) = buf3d ( i, ll, j ) -! if(i == im/2.and.j == (jsta+jend)/2)print*, -! + 'sample F_RimeF= ',i,j,l,F_RimeF( i, j, l ) -! end do -! end do -! end do -! end if -! end if - -! GFS does not have model level cloud fraction -> derive cloud fraction -! CFR=SPVAL -! allocate(qstl(lm)) -! print*,'start deriving cloud fraction' - -! do j=jsta,jend -! do i=1,im -! do l=1,lm -! if(i==im/2.and.j==jsta)print*,'sample T=',t(i,j,l) -! es=fpvsnew(t(i,j,l)) -! if(i==im/2.and.j==jsta)print*,'sample ES=',es -! es=min(es,pmid(i,j,l)) -! if(i==im/2.and.j==jsta)print*,'sample ES=',es -! qstl(l)=con_eps*es/(pmid(i,j,l)+con_epsm1*es) !saturation q for GFS -! end do -! call progcld1 -!................................... - -! --- inputs: -! & ( pmid(i,j,1:lm)/100.,pint(i,j,1:lm+1)/100., -! & t(i,j,1:lm),q(i,j,1:lm),qstl,cwm(i,j,1:lm), -! & gdlat(i,j),gdlon(i,j), -! & 1, lm, lm+1, 0, -! --- outputs: -! & cfr(i,j,1:lm) -! & ) -! do l=1,lm -! cfr(i,j,l)=cldtot(l) -! end do -! end do -! end do - allocate(p2d(im,lm),t2d(im,lm),q2d(im,lm),cw2d(im,lm), & - qs2d(im,lm),cfr2d(im,lm)) - do j=jsta,jend -!$omp parallel do private(i,k,es) - do k=1,lm - do i=1,im - p2d(i,k) = pmid(i,j,k)*0.01 - t2d(i,k) = t(i,j,k) - q2d(i,k) = q(i,j,k) - cw2d(i,k) = cwm(i,j,k) - es = min(fpvsnew(t(i,j,k)),pmid(i,j,k)) - qs2d(i,k) = eps*es/(pmid(i,j,k)+epsm1*es)!saturation q for GFS - enddo - enddo - call progcld1 & -!................................... -! --- inputs: - ( p2d,t2d,q2d,qs2d,cw2d,im,lm,0, & -! --- outputs: - cfr2d & - ) -!$omp parallel do private(i,k) - do k=1,lm - do i=1,im - cfr(i,j,k) = cfr2d(i,k) - enddo - end do - end do - deallocate(p2d,t2d,q2d,qs2d,cw2d,cfr2d) - - -! ask murthy if there is snow rate in GFS -! varname='SR' -! call retrieve_index(index,VarName,varname_all,nrecs,iret) -! if (iret /= 0) then -! print*,VarName," not found in file-Assigned missing values" -! SR=SPVAL -! else -! this_offset=file_offset(index+1)+(jsta_2l-1)*4*im -! this_length=im*(jend_2u-jsta_2l+1) -! call mpi_file_read_at(iunit,this_offset -! + ,sr,this_length,mpi_real4 -! + , mpi_status_ignore, ierr) -! if (ierr /= 0) then -! print*,"Error reading ", VarName,"Assigned missing values" -! SR=SPVAL -! end if -! end if - -! GFS does not have inst cloud fraction for high, middle, and low cloud -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - cfrach(i,j) = spval - cfracl(i,j) = spval - cfracm(i,j) = spval - enddo - enddo - -! ave high cloud fraction using nemsio - VarName='tcdc' - VcoordName='high cld lay' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,avgcfrach) -! where(avgcfrach /= spval)avgcfrach=avgcfrach/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgcfrach(i,j) /= spval) avgcfrach(i,j) = avgcfrach(i,j) * 0.01 - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',avgcfrach(isa,jsa) - -! ave low cloud fraction using nemsio - VarName='tcdc' - VcoordName='low cld lay' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,avgcfracl) -! where(avgcfracl /= spval)avgcfracl=avgcfracl/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgcfracl(i,j) /= spval) avgcfracl(i,j) = avgcfracl(i,j) * 0.01 - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',avgcfracl(isa,jsa) - -! ave middle cloud fraction using nemsio - VarName='tcdc' - VcoordName='mid cld lay' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,avgcfracm) -! where(avgcfracm /= spval)avgcfracm=avgcfracm/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgcfracm(i,j) /= spval) avgcfracm(i,j) = avgcfracm(i,j) * 0.01 - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',avgcfracm(isa,jsa) - -! inst convective cloud fraction using nemsio - VarName='tcdc' - VcoordName='convect-cld laye' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,cnvcfr) -! where(cnvcfr /= spval)cnvcfr=cnvcfr/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (cnvcfr(i,j) /= spval) cnvcfr (i,j)= cnvcfr(i,j) * 0.01 - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',cnvcfr(isa,jsa) - -! slope type using nemsio - VarName='sltyp' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,buf) -! where(buf /= spval)islope=nint(buf) -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i=1,im - if (buf(i,j) < spval) then - islope(i,j) = nint(buf(i,j)) - else - islope(i,j) = 0 - endif - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',islope(isa,jsa) - -! plant canopy sfc wtr in m using nemsio - VarName='cnwat' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,cmc) -! where(cmc /= spval)cmc=cmc/1000. ! convert from kg*m^2 to m -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (cmc(i,j) /= spval) cmc(i,j) = cmc(i,j) * 0.001 - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',cmc(isa,jsa) - -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - grnflx(i,j) = spval ! GFS does not have inst ground heat flux - enddo - enddo - -! GFS does not have snow cover yet -! VarName='gflux' -! VcoordName='sfc' -! l=1 -! if(me == 0)then -! call gfsio_readrecvw34(gfile,trim(VarName),trim(VcoordName) & -! + ,l,dummy,iret=iret) -! if (iret /= 0) then -! print*,VarName," not found in file-Assigned missing values" -! dummy=spval -! end if -! end if -! call mpi_scatterv(dummy,icnt,idsp,mpi_real & -! + , pctsno(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,iret) -! if (iret /= 0)print*,'Error scattering array';stop - -! asuume tg3 in GFS is the same as soiltb in wrf nmm. It's in sfc file, will -! be able to read it when it merges to gfs io -! soiltb is not being put out, comment it out -! VarName='tg3' -! VcoordName='sfc' -! l=1 -! if(me == 0)then -! call gfsio_readrecvw34(gfile,trim(VarName),trim(VcoordName) & -! ,l,dummy,iret=iret) -! if (iret /= 0) then -! print*,VarName," not found in file-Assigned missing values" -! dummy=spval -! end if -! end if -! call mpi_scatterv(dummy(1,1),icnt,idsp,mpi_real & -! , soiltb(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,iret) -! if (iret /= 0)print*,'Error scattering array';stop - -! vegetation fraction in fraction. using nemsio - VarName='veg' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,vegfrc) -! where(vegfrc /= spval) -! vegfrc=vegfrc/100. ! convert to fraction -! elsewhere (vegfrc == spval) -! vegfrc=0. ! set to zero to be reasonable input for crtm -! end where -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (vegfrc(i,j) /= spval) then - vegfrc(i,j) = vegfrc(i,j) * 0.01 - else - vegfrc(i,j) = 0.0 - endif - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',vegfrc(isa,jsa) - -! GFS doesn not yet output soil layer thickness, assign SLDPTH to be the same as nam - - SLDPTH(1) = 0.10 - SLDPTH(2) = 0.3 - SLDPTH(3) = 0.6 - SLDPTH(4) = 1.0 - -! liquid volumetric soil mpisture in fraction using nemsio - VarName='soill' - VcoordName='0-10 cm down' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,sh2o(1,jsta_2l,1)) -! if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,1) - - VarName='soill' - VcoordName='10-40 cm down' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,sh2o(1,jsta_2l,2)) -! if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,2) - - VarName='soill' - VcoordName='40-100 cm down' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,sh2o(1,jsta_2l,3)) -! if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,3) - - VarName='soill' - VcoordName='100-200 cm down' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,sh2o(1,jsta_2l,4)) -! if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,4) - -! volumetric soil moisture using nemsio - VarName='soilw' - VcoordName='0-10 cm down' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,smc(1,jsta_2l,1)) -! if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,1) - - VarName='soilw' - VcoordName='10-40 cm down' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,smc(1,jsta_2l,2)) -! if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,2) - - VarName='soilw' - VcoordName='40-100 cm down' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,smc(1,jsta_2l,3)) -! if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,3) - - VarName='soilw' - VcoordName='100-200 cm down' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,smc(1,jsta_2l,4)) -! if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,4) - -! soil temperature using nemsio - VarName='tmp' - VcoordName='0-10 cm down' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,stc(1,jsta_2l,1)) -! if(debugprint)print*,'sample l','stc',' = ',1,stc(isa,jsa,1) - - VarName='tmp' - VcoordName='10-40 cm down' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,stc(1,jsta_2l,2)) -! if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,2) - - VarName='tmp' - VcoordName='40-100 cm down' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,stc(1,jsta_2l,3)) -! if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,3) - - VarName='tmp' - VcoordName='100-200 cm down' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,stc(1,jsta_2l,4)) -! if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,4) - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - acfrcv(i,j) = spval ! GFS does not output time averaged convective and strat cloud fraction, set acfrcv to spval, ncfrcv to 1 - ncfrcv(i,j) = 1.0 - acfrst(i,j) = spval ! GFS does not output time averaged cloud fraction, set acfrst to spval, ncfrst to 1 - ncfrst(i,j) = 1.0 - ssroff(i,j) = spval ! GFS does not have storm runoff - bgroff(i,j) = spval ! GFS does not have UNDERGROUND RUNOFF - rlwin(i,j) = spval ! GFS does not have inst incoming sfc longwave - rlwtoa(i,j) = spval ! GFS does not have inst model top outgoing longwave - enddo - enddo -! trdlw(i,j) = 6.0 - ardlw = 1.0 ! GFS incoming sfc longwave has been averaged over 6 hr bucket, set ARDLW to 1 - -! time averaged incoming sfc longwave using nemsio - VarName='dlwrf' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,alwin) - -! time averaged outgoing sfc longwave using gfsio - VarName='ulwrf' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,alwout) -! where(alwout /= spval) alwout=-alwout ! CLDRAD puts a minus sign before gribbing -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (alwout(i,j) /= spval) alwout(i,j) = -alwout(i,j) - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,alwout(isa,jsa) - -! time averaged outgoing model top longwave using gfsio - VarName='ulwrf' - VcoordName='nom. top' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,alwtoa) -! if(debugprint)print*,'sample l',VarName,' = ',1,alwtoa(isa,jsa) - -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - rswin(i,j) = spval ! GFS does not have inst incoming sfc shortwave - rswinc(i,j) = spval ! GFS does not have inst incoming clear sky sfc shortwave - rswout(i,j) = spval ! GFS does not have inst outgoing sfc shortwave - enddo - enddo - -! GFS incoming sfc longwave has been averaged, set ARDLW to 1 - ardsw=1.0 -! trdsw=6.0 - -! time averaged incoming sfc shortwave using gfsio - VarName='dswrf' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,aswin) -! if(debugprint)print*,'sample l',VarName,' = ',1,aswin(isa,jsa) - -! time averaged incoming sfc uv-b using getgb - VarName='duvb' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,auvbin) -! if(debugprint)print*,'sample l',VarName,' = ',1,auvbin(isa,jsa) - -! time averaged incoming sfc clear sky uv-b using getgb - VarName='cduvb' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,auvbinc) -! if(debugprint)print*,'sample l',VarName,' = ',1,auvbinc(isa,jsa) - -! time averaged outgoing sfc shortwave using gfsio - VarName='uswrf' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,aswout) -! where(aswout /= spval) aswout=-aswout ! CLDRAD puts a minus sign before gribbing -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (aswout(i,j) /= spval) aswout(i,j) = -aswout(i,j) - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,aswout(isa,jsa) - -! time averaged model top incoming shortwave - VarName='dswrf' - VcoordName='nom. top' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,aswintoa) - -! time averaged model top outgoing shortwave - VarName='uswrf' - VcoordName='nom. top' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,aswtoa) -! if(debugprint)print*,'sample l',VarName,' = ',1,aswtoa(isa,jsa) - -! time averaged surface sensible heat flux, multiplied by -1 because wrf model flux -! has reversed sign convention using gfsio - VarName='shtfl' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,sfcshx) -! where (sfcshx /= spval)sfcshx=-sfcshx -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sfcshx(i,j) /= spval) sfcshx(i,j) = -sfcshx(i,j) - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,sfcshx(isa,jsa) - -! GFS surface flux has been averaged, set ASRFC to 1 - asrfc=1.0 -! tsrfc=6.0 - -! time averaged surface latent heat flux, multiplied by -1 because wrf model flux -! has reversed sign vonvention using gfsio - VarName='lhtfl' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,sfclhx) -! where (sfclhx /= spval)sfclhx=-sfclhx -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sfclhx(i,j) /= spval) sfclhx(i,j) = -sfclhx(i,j) - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,sfclhx(isa,jsa) - -! time averaged ground heat flux using nemsio - VarName='gflux' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,subshx) -! if(debugprint)print*,'sample l',VarName,' = ',1,subshx(isa,jsa) - -! time averaged zonal momentum flux using gfsio - VarName='uflx' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,sfcux) -! if(debugprint)print*,'sample l',VarName,' = ',1,sfcux(isa,jsa) - -! time averaged meridional momentum flux using nemsio - VarName='vflx' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,sfcvx) -! if(debugprint)print*,'sample l',VarName,' = ',1,sfcvx(isa,jsa) - -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - snopcx(i,j) =spval ! GFS does not have snow phase change heat flux - sfcuvx(i,j) = spval ! GFS does not use total momentum flux - enddo - enddo - -! time averaged zonal gravity wave stress using nemsio - VarName='u-gwd' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,gtaux) -! if(debugprint)print*,'sample l',VarName,' = ',1,gtaux(isa,jsa) - -! time averaged meridional gravity wave stress using getgb - VarName='v-gwd' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,gtauy) -! if(debugprint)print*,'sample l',VarName,' = ',1,gtauy(isa,jsa) - -! time averaged accumulated potential evaporation - VarName='pevpr' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,potevp) -! if(debugprint)print*,'sample l',VarName,' = ',1,potevp(isa,jsa) - - do l=1,lm -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im -! GFS does not have temperature tendency due to long wave radiation - rlwtt(i,j,l) = spval -! GFS does not have temperature tendency due to short wave radiation - rswtt(i,j,l) = spval -! GFS does not have temperature tendency due to latent heating from convection - tcucn(i,j,l) = spval - tcucns(i,j,l) = spval -! GFS does not have temperature tendency due to latent heating from grid scale - train(i,j,l) = spval - enddo - enddo - enddo - -! set avrain to 1 - avrain=1.0 - avcnvc=1.0 - theat=6.0 ! just in case GFS decides to output T tendency - -! 10 m u using nemsio - VarName='ugrd' - VcoordName='10 m above gnd' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,u10) -! if(debugprint)print*,'sample l',VarName,' = ',1,u10(isa,jsa) - do j=jsta,jend - do i=1,im - u10h(i,j)=u10(i,j) - end do - end do - -! 10 m v using gfsio - VarName='vgrd' - VcoordName='10 m above gnd' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,v10) - do j=jsta,jend - do i=1,im - v10h(i,j)=v10(i,j) - end do - end do -! if(debugprint)print*,'sample l',VarName,' = ',1,v10(isa,jsa) - -! vegetation type, it's in GFS surface file, hopefully will merge into gfsio soon - VarName='vgtyp' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,buf) -! where (buf /= spval) -! ivgtyp=nint(buf) -! elsewhere -! ivgtyp=0 !need to feed reasonable value to crtm -! end where -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i=1,im - if (buf(i,j) < spval) then - ivgtyp(i,j) = nint(buf(i,j)) - else - ivgtyp(i,j) = 0 - endif - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,ivgtyp(isa,jsa) - -! soil type, it's in GFS surface file, hopefully will merge into gfsio soon - VarName='sotyp' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,buf) -! where (buf /= spval) -! isltyp=nint(buf) -! elsewhere -! isltyp=0 !need to feed reasonable value to crtm -! end where -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i=1,im - if (buf(i,j) < spval) then - isltyp(i,j) = nint(buf(i,j)) - else - isltyp(i,j) = 0 - endif - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,isltyp(isa,jsa) - -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - smstav(i,j) = spval ! GFS does not have soil moisture availability - smstot(i,j) = spval ! GFS does not have total soil moisture - sfcevp(i,j) = spval ! GFS does not have accumulated surface evaporation - sfcexc(i,j) = spval ! GFS does not have surface exchange coefficient - acsnow(i,j) = spval ! GFS does not have averaged accumulated snow - acsnom(i,j) = spval ! GFS does not have snow melt - sst(i,j) = spval ! GFS does not have sst???? - thz0(i,j) = ths(i,j) ! GFS does not have THZ0, use THS to substitute - qz0(i,j) = spval ! GFS does not output humidity at roughness length - uz0(i,j) = spval ! GFS does not output u at roughness length - vz0(i,j) = spval ! GFS does not output humidity at roughness length - enddo - enddo - do l=1,lm -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - EL_PBL(i,j,l) = spval ! GFS does not have mixing length - exch_h(i,j,l) = spval ! GFS does not output exchange coefficient - enddo - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,thz0(isa,jsa) - -! retrieve inst convective cloud top, GFS has cloud top pressure instead of index, -! will need to modify CLDRAD.f to use pressure directly instead of index - VarName='pres' - VcoordName='convect-cld top' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,ptop) -! if(debugprint)print*,'sample l',VarName,' = ',1,ptop(isa,jsa) - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - htop(i,j) = spval - if(ptop(i,j) <= 0.0) ptop(i,j) = spval - enddo - enddo - do j=jsta,jend - do i=1,im - if(ptop(i,j) < spval)then - do l=1,lm - if(ptop(i,j) <= pmid(i,j,l))then - htop(i,j) = l -! if(i==ii .and. j==jj)print*,'sample ptop,pmid pmid-1,pint= ', & -! ptop(i,j),pmid(i,j,l),pmid(i,j,l-1),pint(i,j,l),htop(i,j) - exit - end if - end do - end if - end do - end do - -! retrieve inst convective cloud bottom, GFS has cloud top pressure instead of index, -! will need to modify CLDRAD.f to use pressure directly instead of index - VarName='pres' - VcoordName='convect-cld bot' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,pbot) -! if(debugprint)print*,'sample l',VarName,VcoordName,' = ',1,pbot(isa,jsa) - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - hbot(i,j) = spval - if(pbot(i,j) <= 0.0) pbot(i,j) = spval - enddo - enddo - do j=jsta,jend - do i=1,im -! if(.not.lb(i,j))print*,'false bitmask for pbot at ' -! + ,i,j,pbot(i,j) - if(pbot(i,j) < spval)then - do l=lm,1,-1 - if(pbot(i,j) >= pmid(i,j,l)) then - hbot(i,j) = l -! if(i==ii .and. j==jj)print*,'sample pbot,pmid= ', & -! pbot(i,j),pmid(i,j,l),hbot(i,j) - exit - end if - end do - end if - end do - end do - -! retrieve time averaged low cloud top pressure using nemsio - VarName='pres' - VcoordName='low cld top' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,ptopl) -! if(debugprint)print*,'sample l',VarName,' = ',1,ptopl(isa,jsa) - -! retrieve time averaged low cloud bottom pressure using nemsio - VarName='pres' - VcoordName='low cld bot' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,pbotl) -! if(debugprint)print*,'sample l',VarName,' = ',1,pbotl(isa,jsa) - -! retrieve time averaged low cloud top temperature using nemsio - VarName='tmp' - VcoordName='low cld top' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,Ttopl) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttopl(isa,jsa) - -! retrieve time averaged middle cloud top pressure using nemsio - VarName='pres' - VcoordName='mid cld top' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,ptopm) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,ptopm(isa,jsa) - -! retrieve time averaged middle cloud bottom pressure using nemsio - VarName='pres' - VcoordName='mid cld bot' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,pbotm) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,pbotm(isa,jsa) - -! retrieve time averaged middle cloud top temperature using nemsio - VarName='tmp' - VcoordName='mid cld top' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,Ttopm) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttopm(isa,jsa) - -! retrieve time averaged high cloud top pressure using nemsio ********* - VarName='pres' - VcoordName='high cld top' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,ptoph) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,ptoph(isa,jsa) - -! retrieve time averaged high cloud bottom pressure using nemsio - VarName='pres' - VcoordName='high cld bot' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,pboth) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,pboth(isa,jsa) - -! retrieve time averaged high cloud top temperature using nemsio - VarName='tmp' - VcoordName='high cld top' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,Ttoph) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttoph(isa,jsa) - -! retrieve boundary layer cloud cover using nemsio - VarName='tcdc' - VcoordName='bndary-layer cld' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,pblcfr) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,pblcfr(isa,jsa) -! where (pblcfr /= spval)pblcfr=pblcfr/100. ! convert to fraction -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i=1,im - if (pblcfr(i,j) < spval) pblcfr(i,j) = pblcfr(i,j) * 0.01 - enddo - enddo - -! retrieve cloud work function using nemsio - VarName='cwork' - VcoordName='atmos col' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,cldwork) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,cldwork(isa,jsa) - -! retrieve water runoff using nemsio - VarName='watr' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,runoff) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,runoff(isa,jsa) - -! retrieve shelter max temperature using nemsio - VarName='tmax' - VcoordName='2 m above gnd' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,maxtshltr) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,maxtshltr(isa,jsa) - -! retrieve shelter max temperature using nemsio - VarName='tmin' - VcoordName='2 m above gnd' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,mintshltr) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', & -! 1,mintshltr(im/2,(jsta+jend)/2) - -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - MAXRHSHLTR(i,j) = SPVAL - MINRHSHLTR(i,j) = SPVAL - enddo - enddo - -! retrieve ice thickness using nemsio - VarName='icetk' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,dzice) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,dzice(isa,jsa) - -! retrieve wilting point using nemsio - VarName='wilt' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,smcwlt) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,smcwlt(isa,jsa) - -! retrieve sunshine duration using nemsio - VarName='sunsd' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,suntime) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,suntime(isa,jsa) - -! retrieve field capacity using nemsio - VarName='fldcp' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,fieldcapa) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,fieldcapa(isa,jsa) - -! GFS does not have deep convective cloud top and bottom fields - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - HTOPD(i,j) = SPVAL - HBOTD(i,j) = SPVAL - HTOPS(i,j) = SPVAL - HBOTS(i,j) = SPVAL - CUPPT(i,j) = SPVAL - enddo - enddo - -! -!!!! DONE GETTING -! Will derive isobaric OMEGA from continuity equation later. -! OMGA=SPVAL -! -! -! retrieve d3d fields if it's listed -! ---------------------------------- - if (me == 0) print*,'iostatus for d3d file= ',iostatusD3D - if(iostatusD3D == 0) then ! start reading d3d file -! retrieve longwave tendency using getgb - Index=41 - VarName='LW RAD TEMP TNDY' - jpds=-1.0 - jgds=-1.0 - jpds(5)=251 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,rlwtt(1,jsta_2l,ll)) - end do - -! retrieve shortwave tendency using getgb - Index=40 - VarName='SW RAD TEMP TNDY' - jpds=-1.0 - jgds=-1.0 - jpds(5)=250 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,rswtt(1,jsta_2l,ll)) - end do - -! retrieve vertical diffusion tendency using getgb - Index=356 - VarName='VDIFF TNDY' - jpds=-1.0 - jgds=-1.0 - jpds(5)=246 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,vdifftt(1,jsta_2l,ll)) - end do - -! retrieve deep convective tendency using getgb - Index=79 - VarName='AVE CNVCT RN TMPTDY' - jpds=-1.0 - jgds=-1.0 - jpds(5)=242 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,tcucn(1,jsta_2l,ll)) - end do - -! retrieve shallow convective tendency using getgb - Index=358 - VarName='S CNVCT TNDY' - jpds=-1.0 - jgds=-1.0 - jpds(5)=244 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,tcucns(1,jsta_2l,ll)) - end do - -! retrieve grid scale latent heat tendency using getgb - Index=78 - VarName='AVE GRDSCL RN TMPTDY' - jpds=-1.0 - jgds=-1.0 - jpds(5)=241 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,train(1,jsta_2l,ll)) - end do - -! retrieve vertical diffusion moistening using getgb - Index=360 - VarName='Vertical diffusion moistening' - jpds=-1.0 - jgds=-1.0 - jpds(5)=249 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,vdiffmois(1,jsta_2l,ll)) - end do - -! retrieve deep convection moistening using getgb - Index=361 - VarName='deep convection moistening' - jpds=-1.0 - jgds=-1.0 - jpds(5)=243 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,dconvmois(1,jsta_2l,ll)) - end do - -! retrieve shallow convection moistening using getgb - Index=362 - VarName='shallow convection moistening' - jpds=-1.0 - jgds=-1.0 - jpds(5)=245 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,sconvmois(1,jsta_2l,ll)) - end do - -! retrieve non-radiation tendency using getgb - Index=363 - VarName='non-radiation tendency' - jpds=-1.0 - jgds=-1.0 - jpds(5)=173 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,nradtt(1,jsta_2l,ll)) - end do - -! retrieve Vertical diffusion of ozone using getgb - Index=364 - VarName='Vertical diffusion of ozone' - jpds=-1.0 - jgds=-1.0 - jpds(5)=174 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,o3vdiff(1,jsta_2l,ll)) - end do - -! retrieve ozone production using getgb - Index=365 - VarName='Ozone production' - jpds=-1.0 - jgds=-1.0 - jpds(5)=175 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,o3prod(1,jsta_2l,ll)) - end do - -! retrieve ozone tendency using getgb - Index=366 - VarName='Ozone tendency' - jpds=-1.0 - jgds=-1.0 - jpds(5)=188 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,o3tndy(1,jsta_2l,ll)) - end do - -! retrieve mass weighted PV using getgb - Index=367 - VarName='Mass weighted PV' - jpds=-1.0 - jgds=-1.0 - jpds(5)=139 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,mwpv(1,jsta_2l,ll)) - end do - -! retrieve OZONE TNDY using getgb - Index=368 - VarName='?' - jpds=-1.0 - jgds=-1.0 - jpds(5)=239 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,unknown(1,jsta_2l,ll)) - end do - -! retrieve vertical diffusion zonal acceleration - Index=369 - VarName='VDIFF Z ACCE' - jpds=-1.0 - jgds=-1.0 - jpds(5)=247 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,vdiffzacce(1,jsta_2l,ll)) - end do - -! retrieve gravity drag zonal acceleration - Index=370 - VarName='G DRAG Z ACCE' - jpds=-1.0 - jgds=-1.0 - jpds(5)=181 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,zgdrag(1,jsta_2l,ll)) - end do - -! retrieve convective U momemtum mixing - Index=371 - VarName='CNVCT U M MIX' - jpds=-1.0 - jgds=-1.0 - jpds(5)=183 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,cnvctummixing(1,jsta_2l,ll)) - end do - -! retrieve vertical diffusion meridional acceleration - Index=372 - VarName='VDIFF M ACCE' - jpds=-1.0 - jgds=-1.0 - jpds(5)=248 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,vdiffmacce(1,jsta_2l,ll)) - end do - -! retrieve gravity drag meridional acceleration - Index=373 - VarName='G DRAG M ACCE' - jpds=-1.0 - jgds=-1.0 - jpds(5)=182 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,mgdrag(1,jsta_2l,ll)) - end do - -! retrieve convective V momemtum mixing - Index=374 - VarName='CNVCT V M MIX' - jpds=-1.0 - jgds=-1.0 - jpds(5)=184 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,cnvctvmmixing(1,jsta_2l,ll)) - end do - -! retrieve nonconvective cloud fraction - Index=375 - VarName='N CNVCT CLD FRA' - jpds=-1.0 - jgds=-1.0 - jpds(5)=213 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,ncnvctcfrac(1,jsta_2l,ll)) - end do - -! retrieve convective upward mass flux - Index=391 - VarName='CNVCT U M FLX' - jpds=-1.0 - jgds=-1.0 - jpds(5)=202 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,cnvctumflx(1,jsta_2l,ll)) - end do - -! retrieve convective downward mass flux - Index=392 - VarName='CNVCT D M FLX' - jpds=-1.0 - jgds=-1.0 - jpds(5)=209 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,cnvctdmflx(1,jsta_2l,ll)) - end do - -! retrieve nonconvective detraintment flux - Index=393 - VarName='CNVCT DET M FLX' - jpds=-1.0 - jgds=-1.0 - jpds(5)=219 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,cnvctdetmflx(1,jsta_2l,ll)) - end do - -! retrieve cnvct gravity drag zonal acceleration - Index=394 - VarName='CNVCT G DRAG Z ACCE' - jpds=-1.0 - jgds=-1.0 - jpds(5)=196 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,cnvctzgdrag(1,jsta_2l,ll)) - end do - -! retrieve cnvct gravity drag meridional acceleration - Index=395 - VarName='CNVCT G DRAG M ACCE' - jpds=-1.0 - jgds=-1.0 - jpds(5)=197 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,cnvctmgdrag(1,jsta_2l,ll)) - end do - - call baclose(iunitd3d,status) - print*,'done reading D3D fields' - - end if ! end of d3d file read - ! -------------------- - print *,'after d3d files reading,mype=',me - -! Retrieve aer fields if it's listed (GOCART) - print *, 'iostatus for aer file=', iostatusAER - if(iostatusAER == 0) then ! start reading aer file - -! retrieve dust emission fluxes - do K = 1, nbin_du - if ( K == 1) VarName='DUEM001' - if ( K == 2) VarName='DUEM002' - if ( K == 3) VarName='DUEM003' - if ( K == 4) VarName='DUEM004' - if ( K == 5) VarName='DUEM005' - VcoordName='atmos col' - l=1 - call getnemsandscatter(me,rfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,duem(1,jsta_2l,K)) -! if(debugprint)print*,'sample ',VarName,' = ',duem(isa,jsa,k) - enddo - -! retrieve dust sedimentation fluxes - do K = 1, nbin_du - if ( K == 1) VarName='DUSD001' - if ( K == 2) VarName='DUSD002' - if ( K == 3) VarName='DUSD003' - if ( K == 4) VarName='DUSD004' - if ( K == 5) VarName='DUSD005' - VcoordName='atmos col' - l=1 - call getnemsandscatter(me,rfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,dusd(1,jsta_2l,K)) -! if(debugprint)print*,'sample ',VarName,' = ',dusd(isa,jsa,k) - enddo - -! retrieve dust dry deposition fluxes - do K = 1, nbin_du - if ( K == 1) VarName='DUDP001' - if ( K == 2) VarName='DUDP002' - if ( K == 3) VarName='DUDP003' - if ( K == 4) VarName='DUDP004' - if ( K == 5) VarName='DUDP005' - VcoordName='atmos col' - l=1 - call getnemsandscatter(me,rfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,dudp(1,jsta_2l,K)) - print *,'dudp,ck=',maxval(dudp(1:im,jsta:jend,k)), & - minval(dudp(1:im,jsta:jend,k)) -! if(debugprint)print*,'sample ',VarName,' = ',dudp(isa,jsa,k) - enddo - -! retrieve dust wet deposition fluxes - do K = 1, nbin_du - if ( K == 1) VarName='DUWT001' - if ( K == 2) VarName='DUWT002' - if ( K == 3) VarName='DUWT003' - if ( K == 4) VarName='DUWT004' - if ( K == 5) VarName='DUWT005' - VcoordName='atmos col' - l=1 - call getnemsandscatter(me,rfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,duwt(1,jsta_2l,K)) -! if(debugprint)print*,'sample ',VarName,' = ',duwt(isa,jsa,k) - enddo - -! retrieve sfc mass concentration - VarName='DUSMASS' - VcoordName='atmos col' - l=1 - call getnemsandscatter(me,rfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,dusmass) -! if(debugprint)print*,'sample ',VarName,' = ',dusmass(isa,jsa) - -! retrieve col mass density - VarName='DUCMASS' - VcoordName='atmos col' - l=1 - call getnemsandscatter(me,rfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,ducmass) -! if(debugprint)print*,'sample ',VarName,' = ',ducmass(isa,jsa) - -! retrieve sfc mass concentration (pm2.5) - VarName='DUSMASS25' - VcoordName='atmos col' - l=1 - call getnemsandscatter(me,rfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,dusmass25) -! if(debugprint)print*,'sample ',VarName,' = ',dusmass25(isa,jsa) - -! retrieve col mass density (pm2.5) - VarName='DUCMASS25' - VcoordName='atmos col' - l=1 - call getnemsandscatter(me,rfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,ducmass25) -! if(debugprint)print*,'sample ',VarName,' = ',ducmass25(isa,jsa) - - if (me == 0) print *,'after aer files reading,mype=',me - end if ! end of aer file read - -! pos east - call collect_loc(gdlat,dummy) - if(me == 0)then - latstart = nint(dummy(1,1)*gdsdegr) - latlast = nint(dummy(im,jm)*gdsdegr) - print*,'laststart,latlast B bcast= ',latstart,latlast,'gdsdegr=',gdsdegr,& - 'dummy(1,1)=',dummy(1,1),dummy(im,jm),'gdlat=',gdlat(1,1) - end if - call mpi_bcast(latstart,1,MPI_INTEGER,0,mpi_comm_comp,irtn) - call mpi_bcast(latlast,1,MPI_INTEGER,0,mpi_comm_comp,irtn) - write(6,*) 'laststart,latlast,me A calling bcast=',latstart,latlast,me - call collect_loc(gdlon,dummy) - if(me == 0)then - lonstart = nint(dummy(1,1)*gdsdegr) - lonlast = nint(dummy(im,jm)*gdsdegr) - end if - call mpi_bcast(lonstart,1,MPI_INTEGER,0,mpi_comm_comp,irtn) - call mpi_bcast(lonlast, 1,MPI_INTEGER,0,mpi_comm_comp,irtn) - - write(6,*)'lonstart,lonlast A calling bcast=',lonstart,lonlast -! -! ncdump -h -!! -!! - write(6,*) 'filename in INITPOST=', filename,' is' - -! status=nf_open(filename,NF_NOWRITE,ncid) -! write(6,*) 'returned ncid= ', ncid -! status=nf_get_att_real(ncid,varid,'DX',tmp) -! dxval=int(tmp) -! status=nf_get_att_real(ncid,varid,'DY',tmp) -! dyval=int(tmp) -! status=nf_get_att_real(ncid,varid,'CEN_LAT',tmp) -! cenlat=int(1000.*tmp) -! status=nf_get_att_real(ncid,varid,'CEN_LON',tmp) -! cenlon=int(1000.*tmp) -! status=nf_get_att_real(ncid,varid,'TRUELAT1',tmp) -! truelat1=int(1000.*tmp) -! status=nf_get_att_real(ncid,varid,'TRUELAT2',tmp) -! truelat2=int(1000.*tmp) -! status=nf_get_att_real(ncid,varid,'MAP_PROJ',tmp) -! maptype=int(tmp) -! status=nf_close(ncid) - -! dxval=30000. -! dyval=30000. -! -! write(6,*) 'dxval= ', dxval -! write(6,*) 'dyval= ', dyval -! write(6,*) 'cenlat= ', cenlat -! write(6,*) 'cenlon= ', cenlon -! write(6,*) 'truelat1= ', truelat1 -! write(6,*) 'truelat2= ', truelat2 -! write(6,*) 'maptype is ', maptype -! - -! close up shop -! call ext_int_ioclose ( DataHandle, Status ) - -! generate look up table for lifted parcel calculations - - THL = 210. - PLQ = 70000. - pt_TBL = 10000. ! this is for 100 hPa added by Moorthi - - CALL TABLE(PTBL,TTBL,PT_TBL, & - RDQ,RDTH,RDP,RDTHE,PL,THL,QS0,SQS,STHE,THE0) - - CALL TABLEQ(TTBLQ,RDPQ,RDTHEQ,PLQ,THL,STHEQ,THE0Q) - -! -! - IF(ME == 0)THEN - WRITE(6,*)' SPL (POSTED PRESSURE LEVELS) BELOW: ' - WRITE(6,51) (SPL(L),L=1,LSM) - 50 FORMAT(14(F4.1,1X)) - 51 FORMAT(8(F8.1,1X)) - ENDIF -! -! COMPUTE DERIVED TIME STEPPING CONSTANTS. -! -!MEB need to get DT -! DT = 120. !MEB need to get DT -! NPHS = 4 !MEB need to get physics DT -! TPREC=float(ifhr) -!MEB need to get DT - -!how am i going to get this information? -! 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) -!how am i going to get this information? -! -! IF(ME == 0)THEN -! WRITE(6,*)' ' -! WRITE(6,*)'DERIVED TIME STEPPING CONSTANTS' -! WRITE(6,*)' NPREC,NHEAT,NSRFC : ',NPREC,NHEAT,NSRFC -! WRITE(6,*)' NCLOD,NRDSW,NRDLW : ',NCLOD,NRDSW,NRDLW -! ENDIF -! -! COMPUTE DERIVED MAP OUTPUT CONSTANTS. -!$omp parallel do private(l) - DO L = 1,LSM - ALSL(L) = LOG(SPL(L)) - END DO -! -!HC WRITE IGDS OUT FOR WEIGHTMAKER TO READ IN AS KGDSIN - if(me == 0)then - print*,'writing out igds' - igdout = 110 -! open(igdout,file='griddef.out',form='unformatted' -! + ,status='unknown') - if(maptype == 1)THEN ! Lambert conformal - WRITE(igdout)3 - WRITE(6,*)'igd(1)=',3 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)8 - WRITE(igdout)CENLON - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)0 - WRITE(igdout)64 - WRITE(igdout)TRUELAT2 - WRITE(igdout)TRUELAT1 - WRITE(igdout)255 - ELSE IF(MAPTYPE == 2)THEN !Polar stereographic - WRITE(igdout)5 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)8 - WRITE(igdout)CENLON - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)0 - WRITE(igdout)64 - WRITE(igdout)TRUELAT2 !Assume projection at +-90 - WRITE(igdout)TRUELAT1 - WRITE(igdout)255 - ! Note: The calculation of the map scale factor at the standard - ! lat/lon and the PSMAPF - ! Get map factor at 60 degrees (N or S) for PS projection, which will - ! be needed to correctly define the DX and DY values in the GRIB GDS - if (TRUELAT1 < 0.) THEN - LAT = -60. - else - LAT = 60. - end if - - CALL MSFPS (LAT,TRUELAT1*0.001,PSMAPF) - - ELSE IF(MAPTYPE == 3) THEN !Mercator - WRITE(igdout)1 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)8 - WRITE(igdout)latlast - WRITE(igdout)lonlast - WRITE(igdout)TRUELAT1 - WRITE(igdout)0 - WRITE(igdout)64 - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)255 - ELSE IF(MAPTYPE == 0 .OR. MAPTYPE == 203)THEN !A STAGGERED E-GRID - WRITE(igdout)203 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)136 - WRITE(igdout)CENLAT - WRITE(igdout)CENLON - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)64 - WRITE(igdout)0 - WRITE(igdout)0 - WRITE(igdout)0 - END IF - end if -! -! close all files -! - call nemsio_close(nfile,iret=status) - call nemsio_close(ffile,iret=status) - call nemsio_close(rfile,iret=status) -! call baclose(iunit,status) - - RETURN - END - - diff --git a/sorc/ncep_post.fd/INITPOST_GFS_NETCDF.f b/sorc/ncep_post.fd/INITPOST_GFS_NETCDF.f deleted file mode 100644 index b61732212..000000000 --- a/sorc/ncep_post.fd/INITPOST_GFS_NETCDF.f +++ /dev/null @@ -1,2761 +0,0 @@ -!> @file -! . . . -!> SUBPROGRAM: INITPOST_NETCDF INITIALIZE POST FOR RUN -!! PRGRMMR: Hui-Ya Chuang DATE: 2016-03-04 -!! -!! ABSTRACT: THIS ROUTINE INITIALIZES CONSTANTS AND -!! VARIABLES AT THE START OF GFS MODEL OR POST -!! PROCESSOR RUN. -!! -!! REVISION HISTORY -!! 2017-08-11 H Chuang start from INITPOST_GFS_NEMS_MPIIO.f -!! 2021-03-11 Bo Cui change local arrays to dimension (im,jsta:jend) -!! -!! USAGE: CALL INITPOST_NETCDF -!! INPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - CTLBLK -!! LOOKUP -!! SOILDEPTH -!! -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : CRAY C-90 -!! - SUBROUTINE INITPOST_GFS_NETCDF(ncid3d) - - - use netcdf - use vrbls4d, only: dust, SALT, SUSO, SOOT, WASO, PP25, PP10 - use vrbls3d, only: t, q, uh, vh, pmid, pint, alpint, dpres, zint, zmid, o3, & - qqr, qqs, cwm, qqi, qqw, omga, rhomid, q2, cfr, rlwtt, rswtt, tcucn, & - tcucns, train, el_pbl, exch_h, vdifftt, vdiffmois, dconvmois, nradtt, & - o3vdiff, o3prod, o3tndy, mwpv, unknown, vdiffzacce, zgdrag,cnvctummixing, & - vdiffmacce, mgdrag, cnvctvmmixing, ncnvctcfrac, cnvctumflx, cnvctdmflx, & - cnvctzgdrag, sconvmois, cnvctmgdrag, cnvctdetmflx, duwt, duem, dusd, dudp, & - wh, qqg, ref_10cm - use vrbls2d, only: f, pd, fis, pblh, ustar, z0, ths, qs, twbs, qwbs, avgcprate, & - cprate, avgprec, prec, lspa, sno, si, cldefi, th10, q10, tshltr, pshltr, & - tshltr, albase, avgalbedo, avgtcdc, czen, czmean, mxsnal, radot, sigt4, & - cfrach, cfracl, cfracm, avgcfrach, qshltr, avgcfracl, avgcfracm, cnvcfr, & - islope, cmc, grnflx, vegfrc, acfrcv, ncfrcv, acfrst, ncfrst, ssroff, & - bgroff, rlwin, rlwtoa, cldwork, alwin, alwout, alwtoa, rswin, rswinc, & - rswout, aswin, auvbin, auvbinc, aswout, aswtoa, sfcshx, sfclhx, subshx, & - snopcx, sfcux, sfcvx, sfcuxi, sfcvxi, sfcuvx, gtaux, gtauy, potevp, u10, v10, smstav, & - smstot, ivgtyp, isltyp, sfcevp, sfcexc, acsnow, acsnom, sst, thz0, qz0, & - uz0, vz0, ptop, htop, pbot, hbot, ptopl, pbotl, ttopl, ptopm, pbotm, ttopm, & - ptoph, pboth, pblcfr, ttoph, runoff, maxtshltr, mintshltr, maxrhshltr, & - minrhshltr, dzice, smcwlt, suntime, fieldcapa, htopd, hbotd, htops, hbots, & - cuppt, dusmass, ducmass, dusmass25, ducmass25, aswintoa,rel_vort_maxhy1, & - maxqshltr, minqshltr, acond, sr, u10h, v10h,refd_max, w_up_max, w_dn_max, & - up_heli_max,up_heli_min,up_heli_max03,up_heli_min03,rel_vort_max01,u10max, v10max, & - avgedir,avgecan,avgetrans,avgesnow,avgprec_cont,avgcprate_cont,rel_vort_max, & - avisbeamswin,avisdiffswin,airbeamswin,airdiffswin,refdm10c_max,wspd10max, & - alwoutc,alwtoac,aswoutc,aswtoac,alwinc,aswinc,avgpotevp,snoavg, & - ti,aod550,du_aod550,ss_aod550,su_aod550,oc_aod550,bc_aod550 - use soil, only: sldpth, sh2o, smc, stc - use masks, only: lmv, lmh, htm, vtm, gdlat, gdlon, dx, dy, hbm2, sm, sice - use physcons_post, only: grav => con_g, fv => con_fvirt, rgas => con_rd, & - eps => con_eps, epsm1 => con_epsm1 - use params_mod, only: erad, dtr, tfrz, h1, d608, rd, p1000, capa,pi - use lookup_mod, only: thl, plq, ptbl, ttbl, rdq, rdth, rdp, rdthe, pl, qs0, sqs, sthe, & - ttblq, rdpq, rdtheq, stheq, the0q, the0 - use ctlblk_mod, only: me, mpi_comm_comp, icnt, idsp, jsta, jend, ihrst, idat, sdat, ifhr, & - ifmin, filename, tprec, tclod, trdlw, trdsw, tsrfc, tmaxmin, td3d, restrt, sdat, & - jend_m, imin, imp_physics, dt, spval, pdtop, pt, qmin, nbin_du, nphs, dtq2, ardlw,& - ardsw, asrfc, avrain, avcnvc, theat, gdsdegr, spl, lsm, alsl, im, jm, im_jm, lm, & - jsta_2l, jend_2u, nsoil, lp1, icu_physics, ivegsrc, novegtype, nbin_ss, nbin_bc, & - nbin_oc, nbin_su, gocart_on, pt_tbl, hyb_sigp, filenameFlux, fileNameAER,rdaod - use gridspec_mod, only: maptype, gridtype, latstart, latlast, lonstart, lonlast, cenlon, & - dxval, dyval, truelat2, truelat1, psmapf, cenlat,lonstartv, lonlastv, cenlonv, & - latstartv, latlastv, cenlatv,latstart_r,latlast_r,lonstart_r,lonlast_r - use upp_physics, only: fpvsnew -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none -! -! type(nemsio_gfile) :: nfile,ffile,rfile - integer,parameter :: nvar2d=48 -! character(nemsio_charkind) :: name2d(nvar2d) - integer :: nvar3d, numDims -! character(nemsio_charkind), allocatable :: name3din(:), name3dout(:) -! character(nemsio_charkind) :: varname,levtype -! -! INCLUDE/SET PARAMETERS. -! - INCLUDE "mpif.h" - -! integer,parameter:: MAXPTS=1000000 ! max im*jm points -! -! real,parameter:: con_g =9.80665e+0! gravity -! real,parameter:: con_rv =4.6150e+2 ! gas constant H2O -! real,parameter:: con_rd =2.8705e+2 ! gas constant air -! real,parameter:: con_fvirt =con_rv/con_rd-1. -! real,parameter:: con_eps =con_rd/con_rv -! real,parameter:: con_epsm1 =con_rd/con_rv-1 -! -! This version of INITPOST shows how to initialize, open, read from, and -! close a NetCDF dataset. In order to change it to read an internal (binary) -! dataset, do a global replacement of _ncd_ with _int_. - - real, parameter :: gravi = 1.0/grav - character(len=20) :: VarName, VcoordName - integer :: Status, fldsize, fldst, recn, recn_vvel - character startdate*19,SysDepInfo*80,cgar*1 - character startdate2(19)*4 -! -! NOTE: SOME INTEGER VARIABLES ARE READ INTO DUMMY ( A REAL ). THIS IS OK -! AS LONG AS REALS AND INTEGERS ARE THE SAME SIZE. -! -! ALSO, EXTRACT IS CALLED WITH DUMMY ( A REAL ) EVEN WHEN THE NUMBERS ARE -! INTEGERS - THIS IS OK AS LONG AS INTEGERS AND REALS ARE THE SAME SIZE. - LOGICAL RUNB,SINGLRST,SUBPOST,NEST,HYDRO,IOOMG,IOALL -! logical, parameter :: debugprint = .true., zerout = .false. - logical, parameter :: debugprint = .false., zerout = .false. - logical :: convert_rad_to_deg=.false. - CHARACTER*32 varcharval -! CHARACTER*40 CONTRL,FILALL,FILMST,FILTMP,FILTKE,FILUNV,FILCLD,FILRAD,FILSFC - CHARACTER*4 RESTHR - CHARACTER FNAME*255,ENVAR*50 - INTEGER IDATE(8),JDATE(8),JPDS(200),JGDS(200),KPDS(200),KGDS(200) -! LOGICAL*1 LB(IM,JM) -! -! INCLUDE COMMON BLOCKS. -! -! DECLARE VARIABLES. -! -! REAL fhour -! integer nfhour ! forecast hour from nems io file - integer fhzero !bucket - real dtp !physics time step - REAL RINC(5) - -! REAL FI(IM,JM,2) - REAL DUMMY(IM,JM) - -!jw - integer ii,jj,js,je,iyear,imn,iday,itmp,ioutcount,istatus, & - I,J,L,ll,k,kf,irtn,igdout,n,Index,nframe, & - nframed2,iunitd3d,ierr,idum,iret,nrec,idrt - integer ncid3d,ncid2d,varid,nhcas - real TSTART,TLMH,TSPH,ES,FACT,soilayert,soilayerb,zhour,dum, & - tvll,pmll,tv, tx1, tx2 - - character*20,allocatable :: recname(:) - integer, allocatable :: reclev(:), kmsk(:,:) - real, allocatable :: glat1d(:), glon1d(:), qstl(:) - real, allocatable :: wrk1(:,:), wrk2(:,:) - real, allocatable :: p2d(:,:), t2d(:,:), q2d(:,:), & - qs2d(:,:), cw2d(:,:), cfr2d(:,:) - real(kind=4),allocatable :: vcoord4(:,:,:) - real, dimension(lm+1) :: ak5, bk5 - real*8, allocatable :: pm2d(:,:), pi2d(:,:) - real, allocatable :: tmp(:) - real :: buf(im,jsta_2l:jend_2u) - real :: buf3d(im,jsta_2l:jend_2u,lm) - -! real buf(im,jsta_2l:jend_2u),bufsoil(im,nsoil,jsta_2l:jend_2u) & -! ,buf3d(im,jsta_2l:jend_2u,lm),buf3d2(im,lp1,jsta_2l:jend_2u) - - real LAT - integer isa, jsa, latghf, jtem, idvc, idsl, nvcoord, ip1, nn, npass - - integer, parameter :: npass2=5, npass3=30 - real, parameter :: third=1.0/3.0 - INTEGER, DIMENSION(2) :: ij4min, ij4max - REAL :: omgmin, omgmax - real, allocatable :: d2d(:,:), u2d(:,:), v2d(:,:), omga2d(:,:) - REAL, ALLOCATABLE :: ps2d(:,:),psx2d(:,:),psy2d(:,:) - real, allocatable :: div3d(:,:,:) - real(kind=4),allocatable :: vcrd(:,:) - real :: dum_const - -!*********************************************************************** -! START INIT HERE. -! - WRITE(6,*)'INITPOST: ENTER INITPOST_GFS_NETCDF' - WRITE(6,*)'me=',me, & - 'jsta_2l=',jsta_2l,'jend_2u=', & - jend_2u,'im=',im -! - isa = im / 2 - jsa = (jsta+jend) / 2 - -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i=1,im - buf(i,j) = spval - enddo - enddo - - Status=nf90_get_att(ncid3d,nf90_global,'ak',ak5) - if(Status/=0)then - print*,'ak not found; assigning missing value' - ak5=spval - else - if(me==0)print*,'ak5= ',ak5 - end if - Status=nf90_get_att(ncid3d,nf90_global,'idrt',idrt) - if(Status/=0)then - print*,'idrt not in netcdf file,reading grid' - Status=nf90_get_att(ncid3d,nf90_global,'grid',varcharval) - if(Status/=0)then - print*,'idrt and grid not in netcdf file, set default to latlon' - idrt=0 - MAPTYPE=0 - else - if(trim(varcharval)=='rotated_latlon')then - MAPTYPE=207 - idrt=207 - Status=nf90_get_att(ncid3d,nf90_global,'cen_lon',dum_const) - if(Status/=0)then - print*,'cen_lon not found; assigning missing value' - cenlon=spval - else - if(dum_const<0.)then - cenlon=nint((dum_const+360.)*gdsdegr) - else - cenlon=dum_const*gdsdegr - end if - end if - Status=nf90_get_att(ncid3d,nf90_global,'cen_lat',dum_const) - if(Status/=0)then - print*,'cen_lat not found; assigning missing value' - cenlat=spval - else - cenlat=dum_const*gdsdegr - end if - - Status=nf90_get_att(ncid3d,nf90_global,'lon1',dum_const) - if(Status/=0)then - print*,'lonstart_r not found; assigning missing value' - lonstart_r=spval - else - if(dum_const<0.)then - lonstart_r=nint((dum_const+360.)*gdsdegr) - else - lonstart_r=dum_const*gdsdegr - end if - end if - Status=nf90_get_att(ncid3d,nf90_global,'lat1',dum_const) - if(Status/=0)then - print*,'latstart_r not found; assigning missing value' - latstart_r=spval - else - latstart_r=dum_const*gdsdegr - end if - - Status=nf90_get_att(ncid3d,nf90_global,'lon2',dum_const) - if(Status/=0)then - print*,'lonlast_r not found; assigning missing value' - lonlast_r=spval - else - if(dum_const<0.)then - lonlast_r=nint((dum_const+360.)*gdsdegr) - else - lonlast_r=dum_const*gdsdegr - end if - end if - Status=nf90_get_att(ncid3d,nf90_global,'lat2',dum_const) - if(Status/=0)then - print*,'latlast_r not found; assigning missing value' - latlast_r=spval - else - latlast_r=dum_const*gdsdegr - end if - - Status=nf90_get_att(ncid3d,nf90_global,'dlon',dum_const) - if(Status/=0)then - print*,'dlmd not found; assigning missing value' - dxval=spval - else - dxval=dum_const*gdsdegr - end if - Status=nf90_get_att(ncid3d,nf90_global,'dlat',dum_const) - if(Status/=0)then - print*,'dphd not found; assigning missing value' - dyval=spval - else - dyval=dum_const*gdsdegr - end if - - print*,'lonstart,latstart,cenlon,cenlat,dyval,dxval', & - lonstart,latstart,cenlon,cenlat,dyval,dxval - -! Jili Dong add support for regular lat lon (2019/03/22) start - else if(trim(varcharval)=='latlon')then - MAPTYPE=0 - idrt=0 - - Status=nf90_get_att(ncid3d,nf90_global,'lon1',dum_const) - if(Status/=0)then - print*,'lonstart not found; assigning missing value' - lonstart=spval - else - if(dum_const<0.)then - lonstart=nint((dum_const+360.)*gdsdegr) - else - lonstart=dum_const*gdsdegr - end if - end if - Status=nf90_get_att(ncid3d,nf90_global,'lat1',dum_const) - if(Status/=0)then - print*,'latstart not found; assigning missing value' - latstart=spval - else - latstart=dum_const*gdsdegr - end if - - Status=nf90_get_att(ncid3d,nf90_global,'lon2',dum_const) - if(Status/=0)then - print*,'lonlast not found; assigning missing value' - lonlast=spval - else - if(dum_const<0.)then - lonlast=nint((dum_const+360.)*gdsdegr) - else - lonlast=dum_const*gdsdegr - end if - end if - Status=nf90_get_att(ncid3d,nf90_global,'lat2',dum_const) - if(Status/=0)then - print*,'latlast not found; assigning missing value' - latlast=spval - else - latlast=dum_const*gdsdegr - end if - - Status=nf90_get_att(ncid3d,nf90_global,'dlon',dum_const) - if(Status/=0)then - print*,'dlmd not found; assigning missing value' - dxval=spval - else - dxval=dum_const*gdsdegr - end if - Status=nf90_get_att(ncid3d,nf90_global,'dlat',dum_const) - if(Status/=0)then - print*,'dphd not found; assigning missing value' - dyval=spval - else - dyval=dum_const*gdsdegr - end if - - print*,'lonstart,latstart,dyval,dxval', & - lonstart,lonlast,latstart,latlast,dyval,dxval - -! Jili Dong add support for regular lat lon (2019/03/22) end - - else if(trim(varcharval)=='gaussian')then - MAPTYPE=4 - idrt=4 - else ! setting default maptype - MAPTYPE=0 - idrt=0 - end if - end if !end reading grid - end if !end reading idrt - if(me==0)print*,'idrt MAPTYPE= ',idrt,MAPTYPE -! STEP 1. READ MODEL OUTPUT FILE -! -! -!*** -! -! LMH and LMV always = LM for sigma-type vert coord - -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i = 1, im - LMV(i,j) = lm - LMH(i,j) = lm - end do - end do - -! HTM VTM all 1 for sigma-type vert coord - -!$omp parallel do private(i,j,l) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - HTM (i,j,l) = 1.0 - VTM (i,j,l) = 1.0 - end do - end do - end do - - Status=nf90_get_att(ncid3d,nf90_global,'nhcas',nhcas) - if(Status/=0)then - print*,'nhcas not in netcdf file, set default to nonhydro' - nhcas=0 - end if - if(me==0)print*,'nhcas= ',nhcas - if (nhcas == 0 ) then !non-hydrostatic case - nrec=15 - allocate (recname(nrec)) - recname=[character(len=20) :: 'ugrd','vgrd','spfh','tmp','o3mr', & - 'presnh','dzdt', 'clwmr','dpres', & - 'delz','icmr','rwmr', & - 'snmr','grle','cld_amt'] - else - nrec=8 - allocate (recname(nrec)) - recname=[character(len=20) :: 'ugrd','vgrd','tmp','spfh','o3mr', & - 'hypres', 'clwmr','dpres'] - endif - -! write(0,*)'nrec=',nrec - !allocate(recname(nrec),reclevtyp(nrec),reclev(nrec)) - allocate(glat1d(jm),glon1d(im)) - allocate(vcoord4(lm+1,3,2)) - -! hardwire idate for now -! idate=(/2017,08,07,00,0,0,0,0/) -! get cycle start time - Status=nf90_inq_varid(ncid3d,'time',varid) - if(Status/=0)then - print*,'time not in netcdf file, stopping' - STOP 1 - else - Status=nf90_get_att(ncid3d,varid,'units',varcharval) - if(Status/=0)then - print*,'time unit not available' - else - print*,'time unit read from netcdf file= ',varcharval -! assume use hours as unit -! idate_loc=index(varcharval,'since')+6 - read(varcharval,101)idate(1),idate(2),idate(3),idate(4),idate(5) - end if -! Status=nf90_inquire_dimension(ncid3d,varid,len=ntimes) -! allocate(fhours(ntimes)) -! status = nf90_inq_varid(ncid3d,varid,fhours) -! Status=nf90_get_var(ncid3d,varid,nfhour,start=(/1/), & -! count=(/1/)) -! if(Status/=0)then -! print*,'forecast hour not in netcdf file, stopping' -! STOP 1 -! end if - end if - 101 format(T13,i4,1x,i2,1x,i2,1x,i2,1x,i2) - print*,'idate= ',idate(1:5) -! get longitude - Status=nf90_inq_varid(ncid3d,'grid_xt',varid) - Status=nf90_inquire_variable(ncid3d,varid,ndims = numDims) - if(debugprint)print*,'number of dim for gdlon ',numDims - if(numDims==1)then - Status=nf90_get_var(ncid3d,varid,glon1d) - do j=jsta,jend - do i=1,im - gdlon(i,j) = real(glon1d(i),kind=4) - end do - end do - lonstart = nint(glon1d(1)*gdsdegr) - lonlast = nint(glon1d(im)*gdsdegr) - dxval = nint(abs(glon1d(1)-glon1d(2))*gdsdegr) - else if(numDims==2)then - Status=nf90_get_var(ncid3d,varid,dummy) - if(maxval(abs(dummy))<2.0*pi)convert_rad_to_deg=.true. - if(convert_rad_to_deg)then - do j=jsta,jend - do i=1,im - gdlon(i,j) = real(dummy(i,j),kind=4)*180./pi - end do - end do - else - do j=jsta,jend - do i=1,im - gdlon(i,j) = real(dummy(i,j),kind=4) - end do - end do - end if - if(convert_rad_to_deg)then - lonstart = nint(dummy(1,1)*gdsdegr)*180./pi - lonlast = nint(dummy(im,jm)*gdsdegr)*180./pi - dxval = nint(abs(dummy(1,1)-dummy(2,1))*gdsdegr)*180./pi - else - lonstart = nint(dummy(1,1)*gdsdegr) - lonlast = nint(dummy(im,jm)*gdsdegr) - dxval = nint(abs(dummy(1,1)-dummy(2,1))*gdsdegr) - end if - -! Jili Dong add support for regular lat lon (2019/03/22) start - if (MAPTYPE == 0) then - if(lonstart<0.)then - lonstart=lonstart+360.*gdsdegr - end if - if(lonlast<0.)then - lonlast=lonlast+360.*gdsdegr - end if - end if -! Jili Dong add support for regular lat lon (2019/03/22) end - - end if - print*,'lonstart,lonlast,dxval ',lonstart,lonlast,dxval -! get latitude - Status=nf90_inq_varid(ncid3d,'grid_yt',varid) - Status=nf90_inquire_variable(ncid3d,varid,ndims = numDims) - if(debugprint)print*,'number of dim for gdlat ',numDims - if(numDims==1)then - Status=nf90_get_var(ncid3d,varid,glat1d) - do j=jsta,jend - do i=1,im - gdlat(i,j) = real(glat1d(j),kind=4) - end do - end do - latstart = nint(glat1d(1)*gdsdegr) - latlast = nint(glat1d(jm)*gdsdegr) - dyval = nint(abs(glat1d(1)-glat1d(2))*gdsdegr) - else if(numDims==2)then - Status=nf90_get_var(ncid3d,varid,dummy) - if(maxval(abs(dummy))1.0e5)print*,'bad dpres ',i,j,dpres(i,j,l) -!make sure delz is positive -! if(dpres(i,j,l)/=spval .and. t(i,j,l)/=spval .and. & -! q(i,j,l)/=spval .and. buf3d(i,j,l)/=spval)then -! pmid(i,j,l)=rgas*dpres(i,j,l)* & -! t(i,j,l)*(q(i,j,l)*fv+1.0)/grav/abs(buf3d(i,j,l)) -! else -! pmid(i,j,l)=spval -! end if -! dong add missing value - if (wh(i,j,l) < spval) then - omga(i,j,l)=(-1.)*wh(i,j,l)*dpres(i,j,l)/abs(buf3d(i,j,l)) - else - omga(i,j,l) = spval - end if -! if(t(i,j,l)>1000.)print*,'bad T ',t(i,j,l) - enddo - enddo - enddo - call read_netcdf_3d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,recname(11) & - ,lm,qqi(1,jsta_2l,1)) - call read_netcdf_3d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,recname(12) & - ,lm,qqr(1,jsta_2l,1)) - call read_netcdf_3d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,recname(13) & - ,lm,qqs(1,jsta_2l,1)) - call read_netcdf_3d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,recname(14) & - ,lm,qqg(1,jsta_2l,1)) - call read_netcdf_3d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,recname(15) & - ,lm,cfr(1,jsta_2l,1)) -! calculate CWM from FV3 output - do l=1,lm - do j=jsta,jend - do i=1,im - cwm(i,j,l)=qqg(i,j,l)+qqs(i,j,l)+qqr(i,j,l)+qqi(i,j,l)+qqw(i,j,l) - enddo - enddo - if(debugprint)print*,'sample l,t,q,u,v,w,= ',isa,jsa,l & - ,t(isa,jsa,l),q(isa,jsa,l),uh(isa,jsa,l),vh(isa,jsa,l) & - ,wh(isa,jsa,l) - if(debugprint)print*,'sample l cwm for FV3',l, & - cwm(isa,jsa,l) - end do -! max hourly updraft velocity -! VarName='upvvelmax' -! call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,w_up_max) -! if(debugprint)print*,'sample ',VarName,' = ',w_up_max(isa,jsa) - -! max hourly downdraft velocity -! VarName='dnvvelmax' -! call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,w_dn_max) -! if(debugprint)print*,'sample ',VarName,' = ',w_dn_max(isa,jsa) -! max hourly updraft helicity -! VarName='uhmax25' -! call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,up_heli_max) -! if(debugprint)print*,'sample ',VarName,' = ',up_heli_max(isa,jsa) -! min hourly updraft helicity -! VarName='uhmin25' -! call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,up_heli_min) -! if(debugprint)print*,'sample ',VarName,' = ',up_heli_min(isa,jsa) -! max hourly 0-3km updraft helicity -! VarName='uhmax03' -! call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,up_heli_max03) -! if(debugprint)print*,'sample ',VarName,' = ',up_heli_max03(isa,jsa) -! min hourly 0-3km updraft helicity -! VarName='uhmin03' -! call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,up_heli_min03) -! if(debugprint)print*,'sample ',VarName,' = ',up_heli_min03(isa,jsa) - -! max 0-1km relative vorticity max -! VarName='maxvort01' -! call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,rel_vort_max01) -! if(debugprint)print*,'sample ',VarName,' = ',rel_vort_max01(isa,jsa) -! max 0-2km relative vorticity max -! VarName='maxvort02' -! call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,rel_vort_max) -! if(debugprint)print*,'sample ',VarName,' =',rel_vort_max(isa,jsa) -! max hybrid lev 1 relative vorticity max -! VarName='maxvorthy1' -! call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,rel_vort_maxhy1) -! if(debugprint)print*,'sample ',VarName,' =',rel_vort_maxhy1(isa,jsa) -! surface pressure - VarName='pressfc' - call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,pint(1,jsta_2l,lp1)) - do j=jsta,jend - do i=1,im -! if(pint(i,j,lp1)>1.0E6 .or. pint(1,jsta_2l,lp1)<50000.) & -! print*,'bad psfc ',i,j,pint(i,j,lp1) - end do - end do - if(debugprint)print*,'sample ',VarName,' =',pint(isa,jsa,lp1) - - pt = ak5(1) - - do j=jsta,jend - do i=1,im - pint(i,j,1)= pt - end do - end do - - do l=2,lp1 - do j=jsta,jend - do i=1,im - pint(i,j,l) = pint(i,j,l-1) + dpres(i,j,l-1) - enddo - enddo -! if (me == 0) print*,'sample model pint,pmid' ,ii,jj,l & -! ,pint(ii,jj,l),pmid(ii,jj,l) - end do - -!compute pmid from averaged two layer pint - do l=lm,1,-1 - do j=jsta,jend - do i=1,im - pmid(i,j,l) = 0.5*(pint(i,j,l)+pint(i,j,l+1)) - enddo - enddo - enddo - -! do l=lm,1,-1 -! do j=jsta,jend -! do i=1,im -! if(pint(i,j,l+1)/=spval .and. dpres(i,j,l)/=spval)then -! pint(i,j,l)=pint(i,j,l+1)-dpres(i,j,l) -! else -! pint(i,j,l)=spval -! end if -! end do -! end do -! print*,'sample pint= ',isa,jsa,l,pint(isa,jsa,l) -! end do - -! surface height from FV3 -! dong set missing value for zint -! zint=spval - VarName='hgtsfc' - call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,zint(1,jsta_2l,lp1)) - if(debugprint)print*,'sample ',VarName,' =',zint(isa,jsa,lp1) - do j=jsta,jend - do i=1,im - if (zint(i,j,lp1) /= spval) then - fis(i,j) = zint(i,j,lp1) * grav - else - fis(i,j) = spval - endif - enddo - enddo - - do l=lm,1,-1 - do j=jsta,jend - do i=1,im - if(zint(i,j,l+1)/=spval .and. buf3d(i,j,l)/=spval)then -!make sure delz is positive - zint(i,j,l)=zint(i,j,l+1)+abs(buf3d(i,j,l)) -! if(zint(i,j,l)>1.0E6)print*,'bad H ',i,j,l,zint(i,j,l) - else - zint(i,j,l)=spval - end if - end do - end do - print*,'sample zint= ',isa,jsa,l,zint(isa,jsa,l) - end do - - do l=lp1,1,-1 - do j=jsta,jend - do i=1,im - alpint(i,j,l)=log(pint(i,j,l)) - end do - end do - end do - - do l=lm,1,-1 - do j=jsta,jend - do i=1,im - if(zint(i,j,l+1)/=spval .and. zint(i,j,l)/=spval & - .and. pmid(i,j,l)/=spval)then - zmid(i,j,l)=zint(i,j,l+1)+(zint(i,j,l)-zint(i,j,l+1))* & - (log(pmid(i,j,l))-alpint(i,j,l+1))/ & - (alpint(i,j,l)-alpint(i,j,l+1)) - if(zmid(i,j,l)>1.0E6)print*,'bad Hmid ',i,j,l,zmid(i,j,l) - else - zmid(i,j,l)=spval - endif - end do - end do - end do - - - pt = ak5(1) - -! else -! do l=2,lm -!!$omp parallel do private(i,j) -! do j=jsta,jend -! do i=1,im -! pint(i,j,l) = pint(i,j,l-1) + dpres(i,j,l-1) -! enddo -! enddo -! if (me == 0) print*,'sample pint,pmid' ,ii,jj,l,pint(ii,jj,l),pmid(ii,jj,l) -! end do -! endif -! - - deallocate (vcoord4) -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - -! - -! done with 3d file, close it for now - Status=nf90_close(ncid3d) - deallocate(recname) - -! open flux file - Status = nf90_open(trim(fileNameFlux),NF90_NOWRITE, ncid2d) - - if ( Status /= 0 ) then - print*,'error opening ',fileNameFlux, ' Status = ', Status - print*,'skip reading of flux file' - endif - -! IVEGSRC=1 for IGBP, 0 for USGS, 2 for UMD - VarName='IVEGSRC' - Status=nf90_get_att(ncid2d,nf90_global,'IVEGSRC',IVEGSRC) - if (Status /= 0) then - print*,VarName,' not found-Assigned 1 for IGBP as default' - IVEGSRC=1 - end if - if (me == 0) print*,'IVEGSRC= ',IVEGSRC - -! set novegtype based on vegetation classification - if(ivegsrc==2)then - novegtype=13 - else if(ivegsrc==1)then - novegtype=20 - else if(ivegsrc==0)then - novegtype=24 - end if - if (me == 0) print*,'novegtype= ',novegtype - - Status=nf90_get_att(ncid2d,nf90_global,'imp_physics',imp_physics) - if (Status /= 0) then - print*,VarName,' not found-Assigned 11 GFDL as default' - imp_physics=11 - end if - if (me == 0) print*,'MP_PHYSICS= ',imp_physics -! - Status=nf90_get_att(ncid2d,nf90_global,'fhzero',fhzero) - if (Status /= 0) then - print*,VarName,' not found-Assigned 3 hours as default' - fhzero=3 - end if - if (me == 0) print*,'fhzero= ',fhzero -! - Status=nf90_get_att(ncid2d,nf90_global,'dtp',dtp) - if (Status /= 0) then - print*,VarName,' not found-Assigned 90s as default' - dtp=90 - end if - if (me == 0) print*,'dtp= ',dtp -! Initializes constants for Ferrier microphysics - if(imp_physics==5 .or. imp_physics==85 .or. imp_physics==95) then - CALL MICROINIT(imp_physics) - end if - -! Chuang: zhour is when GFS empties bucket last so using this -! to compute buket will result in changing bucket with forecast time. -! set default bucket for now - -! call nemsio_getheadvar(ffile,'zhour',zhour,iret=iret) -! if(iret == 0) then -! tprec = 1.0*ifhr-zhour -! tclod = tprec -! trdlw = tprec -! trdsw = tprec -! tsrfc = tprec -! tmaxmin = tprec -! td3d = tprec -! print*,'tprec from flux file header= ',tprec -! else -! print*,'Error reading accumulation bucket from flux file', & -! 'header - will try to read from env variable FHZER' -! CALL GETENV('FHZER',ENVAR) -! read(ENVAR, '(I2)')idum -! tprec = idum*1.0 -! tclod = tprec -! trdlw = tprec -! trdsw = tprec -! tsrfc = tprec -! tmaxmin = tprec -! td3d = tprec -! print*,'TPREC from FHZER= ',tprec -! end if - - - tprec = float(fhzero) - if(ifhr>240)tprec=12. - tclod = tprec - trdlw = tprec - trdsw = tprec - tsrfc = tprec - tmaxmin = tprec - td3d = tprec - print*,'tprec = ',tprec - - -! start reading 2d netcdf file -! surface pressure -! VarName='pressfc' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & -! ,pint(1,jsta_2l,lp1)) -! if(debugprint)print*,'sample ',VarName,' =',pint(isa,jsa,lp1) -! do l=lm,1,-1 -! do j=jsta,jend -! do i=1,im -! pint(i,j,l)=pint(i,j,l+1)-dpres(i,j,l) -! if(pint(i,j,l)>1.0E6)print*,'bad P ',i,j,l,pint(i,j,l) & -! ,pint(i,j,l+1),dpres(i,j,l) -! end do -! end do -! print*,'sample pint= ',isa,jsa,l,pint(isa,jsa,l) -! end do -! surface height from FV3 already multiplied by G -! VarName='orog' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,fis) -! if(debugprint)print*,'sample ',VarName,' =',fis(isa,jsa) -! do j=jsta,jend -! do i=1,im -! if (fis(i,j) /= spval) then -! zint(i,j,lp1) = fis(i,j) -! fis(i,j) = fis(i,j) * grav -! else -! zint(i,j,lp1) = spval -! fis(i,j) = spval -! endif -! enddo -! enddo - -! do l=lm,1,-1 -! do j=jsta,jend -! do i=1,im -! if(zint(i,j,l+1)/=spval .and. buf3d(i,j,l)/=spval)then -! zint(i,j,l)=zint(i,j,l+1)+buf3d(i,j,l) -! if(zint(i,j,l)>1.0E6)print*,'bad H ',i,j,l,zint(i,j,l) -! else -! zint(i,j,l)=spval -! end if -! end do -! end do -! print*,'sample zint= ',isa,jsa,l,zint(isa,jsa,l) -! end do - -! Per communication with Fanglin, P from model in not monotonic -! so compute P using ak and bk for now Sep. 2017 -! do l=lm,1,-1 -!!!$omp parallel do private(i,j) -! do j=jsta,jend -! do i=1,im -! pint(i,j,l) = ak5(lm+2-l) + bk5(lm+2-l)*pint(i,j,lp1) -! pmid(i,j,l) = 0.5*(pint(i,j,l)+pint(i,j,l+1)) ! for now - -! enddo -! enddo -! print*,'sample pint,pmid' & -! ,l,pint(isa,jsa,l),pmid(isa,jsa,l) -! enddo - -! allocate(wrk1(im,jsta:jend),wrk2(im,jsta:jend)) -! do j=jsta,jend -! do i=1,im -! pd(i,j) = spval ! GFS does not output PD -! pint(i,j,1) = PT -! alpint(i,j,lp1) = log(pint(i,j,lp1)) -! wrk1(i,j) = log(PMID(I,J,LM)) -! wrk2(i,j) = T(I,J,LM)*(Q(I,J,LM)*fv+1.0) -! FI(I,J,1) = FIS(I,J) & -! + wrk2(i,j)*rgas*(ALPINT(I,J,Lp1)-wrk1(i,j)) -! ZMID(I,J,LM) = FI(I,J,1) * gravi -! end do -! end do - -! SECOND, INTEGRATE HEIGHT HYDROSTATICLY, GFS integrate height on -! mid-layer - -! DO L=LM,2,-1 ! omit computing model top height -! ll = l - 1 -! do j = jsta, jend -! do i = 1, im -! alpint(i,j,l) = log(pint(i,j,l)) -! tvll = T(I,J,LL)*(Q(I,J,LL)*fv+1.0) -! pmll = log(PMID(I,J,LL)) - -! FI(I,J,2) = FI(I,J,1) + (0.5*rgas)*(wrk2(i,j)+tvll) & -! * (wrk1(i,j)-pmll) -! ZMID(I,J,LL) = FI(I,J,2) * gravi -! -! FACT = (ALPINT(I,J,L)-wrk1(i,j)) / (pmll-wrk1(i,j)) -! ZINT(I,J,L) = ZMID(I,J,L) +(ZMID(I,J,LL)-ZMID(I,J,L))*FACT -! FI(I,J,1) = FI(I,J,2) -! wrk1(i,J) = pmll -! wrk2(i,j) = tvll -! ENDDO -! ENDDO - -! print*,'L ZINT= ',l,zint(isa,jsa,l),ZMID(isa,jsa,l) -! ,'alpint=',ALPINT(ii,jj,l),'pmid=',LOG(PMID(Ii,Jj,L)), & -! 'pmid(l-1)=',LOG(PMID(Ii,Jj,L-1)),'zmd=',ZMID(Ii,Jj,L), & -! 'zmid(l-1)=',ZMID(Ii,Jj,L-1) -! ENDDO -! deallocate(wrk1,wrk2) - -! do l=lp1,2,-1 -! do j=jsta,jend -! do i=1,im -! alpint(i,j,l)=log(pint(i,j,l)) -! end do -! end do -! end do - -! do l=lm,2,-1 -! do j=jsta,jend -! do i=1,im -! zmid(i,j,l)=zint(i,j,l+1)+(zint(i,j,l)-zint(i,j,l+1))* & -! (log(pmid(i,j,l))-alpint(i,j,l+1))/ & -! (alpint(i,j,l)-alpint(i,j,l+1)) -! if(zmid(i,j,l)>1.0E6)print*,'bad Hmid ',i,j,l,zmid(i,j,l) -! end do -! end do -! end do - -! VarName='refl_10cm' -! do l=1,lm -! call read_netcdf_3d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & -! ,lm,REF_10CM(1,jsta_2l,1)) -! if(debugprint)print*,'sample ',VarName,'isa,jsa,l =' & -! ,REF_10CM(isa,jsa,l),isa,jsa,l -! enddo -!Set REF_10CM as missning since gfs doesn't ouput it - do l=1,lm - do j=jsta,jend - do i=1,im - REF_10CM(i,j,l)=spval - enddo - enddo - enddo - - VarName='land' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sm) - if(debugprint)print*,'sample ',VarName,' =',sm(im/2,(jsta+jend)/2) - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= spval) sm(i,j) = 1.0 - sm(i,j) - enddo - enddo - -! sea ice mask - - VarName = 'icec' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sice) - if(debugprint)print*,'sample ',VarName,' = ',sice(isa,jsa) - -! where(sice /=spval .and. sice >=1.0)sm=0.0 !sea ice has sea -! mask=0 -! GFS flux files have land points with non-zero sea ice, per Iredell, -! these -! points have sea ice changed to zero, i.e., trust land mask more than -! sea ice -! where(sm/=spval .and. sm==0.0)sice=0.0 !specify sea ice=0 at land - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= spval .and. sm(i,j) == 0.0) sice(i,j) = 0.0 - enddo - enddo - - -! PBL height using nemsio - VarName = 'hpbl' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,pblh) - if(debugprint)print*,'sample ',VarName,' = ',pblh(isa,jsa) - -! frictional velocity using nemsio - VarName='fricv' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,ustar) -! if(debugprint)print*,'sample ',VarName,' = ',ustar(isa,jsa) - -! roughness length using getgb - VarName='sfcr' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,z0) -! if(debugprint)print*,'sample ',VarName,' = ',z0(isa,jsa) - -! sfc exchange coeff - VarName='sfexc' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,SFCEXC) - -! aerodynamic conductance - VarName='acond' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,acond) - if(debugprint)print*,'sample ',VarName,' = ',acond(isa,jsa) -! mid day avg albedo - VarName='albdo_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgalbedo) - if(debugprint)print*,'sample ',VarName,' = ',avgalbedo(isa,jsa) - do j=jsta,jend - do i=1,im - if (avgalbedo(i,j) /= spval) avgalbedo(i,j) = avgalbedo(i,j) * 0.01 - enddo - enddo - -! surface potential T using getgb - VarName='tmpsfc' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,ths) - -! where(ths/=spval)ths=ths*(p1000/pint(:,:,lp1))**CAPA ! convert to THS - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (ths(i,j) /= spval) then -! write(0,*)' i=',i,' j=',j,' ths=',ths(i,j),' pint=',pint(i,j,lp1) - ths(i,j) = ths(i,j) * (p1000/pint(i,j,lp1))**capa - endif - QS(i,j) = SPVAL ! GFS does not have surface specific humidity - twbs(i,j) = SPVAL ! GFS does not have inst sensible heat flux - qwbs(i,j) = SPVAL ! GFS does not have inst latent heat flux -!assign sst - if (sm(i,j) /= 0.0) then - sst(i,j) = ths(i,j) * (pint(i,j,lp1)/p1000)**capa - else - sst(i,j) = spval - endif - enddo - enddo - if(debugprint)print*,'sample ',VarName,' = ',ths(isa,jsa) - - -! GFS does not have time step and physics time step, make up ones since they -! are not really used anyway -! NPHS=1. -! DT=90. -! DTQ2 = DT * NPHS !MEB need to get physics DT - DTQ2 = DTP !MEB need to get physics DT - NPHS=1 - DT = DTQ2/NPHS !MEB need to get DT - TSPH = 3600./DT - -! convective precip in m per physics time step using getgb -! read 3 hour bucket - VarName='cpratb_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgcprate) -! where(avgcprate /= spval)avgcprate=avgcprate*dtq2/1000. ! convert to m -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgcprate(i,j) /= spval) avgcprate(i,j) = avgcprate(i,j) * (dtq2*0.001) - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',avgcprate(isa,jsa) - -! print*,'maxval CPRATE: ', maxval(CPRATE) - -! read continuous bucket - VarName='cprat_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgcprate_cont) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgcprate_cont(i,j) /= spval) avgcprate_cont(i,j) = & - avgcprate_cont(i,j) * (dtq2*0.001) - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',avgcprate_cont(isa,jsa) - -! print*,'maxval CPRATE: ', maxval(CPRATE) - -! precip rate in m per physics time step using getgb - VarName='prateb_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgprec) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if(avgprec(i,j) /= spval)avgprec(i,j)=avgprec(i,j)*(dtq2*0.001) - enddo - enddo - - if(debugprint)print*,'sample ',VarName,' = ',avgprec(isa,jsa) - -! prec = avgprec !set avg cprate to inst one to derive other fields - - VarName='prate_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgprec_cont) -! where(avgprec /= spval)avgprec=avgprec*dtq2/1000. ! convert to m -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgprec_cont(i,j) /=spval)avgprec_cont(i,j)=avgprec_cont(i,j) & - * (dtq2*0.001) - enddo - enddo - - if(debugprint)print*,'sample ',VarName,' = ',avgprec_cont(isa,jsa) -! precip rate in m per physics time step - VarName='tprcp' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,prec) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (prec(i,j) /= spval) prec(i,j)=prec(i,j)* (dtq2*0.001) & - * 1000. / dtp - enddo - enddo - -! convective precip rate in m per physics time step - VarName='cnvprcp' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,cprate) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (cprate(i,j) /= spval) then - cprate(i,j) = max(0.,cprate(i,j)) * (dtq2*0.001) & - * 1000. / dtp - else - cprate(i,j) = 0. - endif - enddo - enddo - if(debugprint)print*,'sample ',VarName,' = ',cprate(isa,jsa) - -! GFS does not have accumulated total, gridscale, and convective precip, will use inst precip to derive in SURFCE.f - -! max hourly 1-km agl reflectivity -! VarName='refdmax' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,refd_max) -! if(debugprint)print*,'sample ',VarName,' = ',refd_max(isa,jsa) -! max hourly -10C reflectivity -! VarName='refdmax263k' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,refdm10c_max) -! if(debugprint)print*,'sample ',VarName,' = ',refdm10c_max(isa,jsa) - -! max hourly u comp of 10m agl wind -! VarName='u10max' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,u10max) -! if(debugprint)print*,'sample ',VarName,' = ',u10max(isa,jsa) -! max hourly v comp of 10m agl wind -! VarName='v10max' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,v10max) -! if(debugprint)print*,'sample ',VarName,' = ',v10max(isa,jsa) -! max hourly 10m agl wind speed -! VarName='spd10max' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,wspd10max) -! if(debugprint)print*,'sample ',VarName,' = ',wspd10max(isa,jsa) - - -! 2m T using nemsio - VarName='tmp2m' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,tshltr) - if(debugprint)print*,'sample ',VarName,' = ',tshltr(isa,jsa) - -! inst snow water eqivalent using nemsio - VarName='weasd' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sno) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) == 1.0 .and. sice(i,j)==0.) sno(i,j) = spval - enddo - enddo - if(debugprint)print*,'sample ',VarName,' = ',sno(isa,jsa) - -! ave snow cover - VarName='snowc_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,snoavg) -! snow cover is multipled by 100 in SURFCE before writing it out - do j=jsta,jend - do i=1,im - if (sm(i,j)==1.0 .and. sice(i,j)==0.) snoavg(i,j)=spval - if(snoavg(i,j)/=spval)snoavg(i,j)=snoavg(i,j)/100. - end do - end do - -! snow depth in mm using nemsio - VarName='snod' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,si) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j)==1.0 .and. sice(i,j)==0.) si(i,j)=spval - if (si(i,j) /= spval) si(i,j) = si(i,j) * 1000.0 - CLDEFI(i,j) = SPVAL ! GFS does not have convective cloud efficiency - lspa(i,j) = spval ! GFS does not have similated precip - TH10(i,j) = SPVAL ! GFS does not have 10 m theta - TH10(i,j) = SPVAL ! GFS does not have 10 m theta - Q10(i,j) = SPVAL ! GFS does not have 10 m humidity - ALBASE(i,j) = SPVAL ! GFS does not have snow free albedo - enddo - enddo - if(debugprint)print*,'sample ',VarName,' = ',si(isa,jsa) - -! 2m T using nemsio - VarName='tmp2m' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,tshltr) - if(debugprint)print*,'sample ',VarName,' = ',tshltr(isa,jsa) - -! GFS does not have 2m pres, estimate it, also convert t to theta - Do j=jsta,jend - Do i=1,im - PSHLTR(I,J)=pint(I,J,lm+1)*EXP(-0.068283/tshltr(i,j)) - tshltr(i,j)= tshltr(i,j)*(p1000/PSHLTR(I,J))**CAPA ! convert to theta -! if (j == jm/2 .and. mod(i,50) == 0) -! + print*,'sample 2m T and P after scatter= ' -! + ,i,j,tshltr(i,j),pshltr(i,j) - end do - end do - -! 2m specific humidity using nemsio - VarName='spfh2m' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,qshltr) - if(debugprint)print*,'sample ',VarName,' = ',qshltr(isa,jsa) - -! mid day avg albedo in fraction using nemsio -! VarName='albdosfc' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgalbedo) -!! where(avgalbedo /= spval)avgalbedo=avgalbedo/100. ! convert to fraction -!!$omp parallel do private(i,j) -! do j=jsta,jend -! do i=1,im -! if (avgalbedo(i,j) /= spval) avgalbedo(i,j) = avgalbedo(i,j) * 0.01 -! enddo -! enddo -! if(debugprint)print*,'sample ',VarName,' = ',avgalbedo(isa,jsa) - -! time averaged column cloud fractionusing nemsio - VarName='tcdc_aveclm' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgtcdc) -! where(avgtcdc /= spval)avgtcdc=avgtcdc/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgtcdc(i,j) /= spval) avgtcdc(i,j) = avgtcdc(i,j) * 0.01 - enddo - enddo - if(debugprint)print*,'sample ',VarName,' = ',avgtcdc(isa,jsa) - -! GFS probably does not use zenith angle -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - Czen(i,j) = spval - CZMEAN(i,j) = SPVAL - enddo - enddo - -! maximum snow albedo in fraction using nemsio - VarName='snoalb' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,mxsnal) -! where(mxsnal /= spval)mxsnal=mxsnal/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (mxsnal(i,j) /= spval) mxsnal(i,j) = mxsnal(i,j) * 0.01 - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',mxsnal(isa,jsa) - -! GFS probably does not use sigt4, set it to sig*t^4 -!$omp parallel do private(i,j,tlmh) - Do j=jsta,jend - Do i=1,im - TLMH = T(I,J,LM) * T(I,J,LM) - Sigt4(i,j) = 5.67E-8 * TLMH * TLMH - End do - End do - -! TG is not used, skip it for now - -! GFS does not have inst cloud fraction for high, middle, and low cloud -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - cfrach(i,j) = spval - cfracl(i,j) = spval - cfracm(i,j) = spval - enddo - enddo - -! ave high cloud fraction using nemsio - VarName='tcdc_avehcl' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgcfrach) -! where(avgcfrach /= spval)avgcfrach=avgcfrach/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgcfrach(i,j) /= spval) avgcfrach(i,j) = avgcfrach(i,j) * 0.01 - enddo - enddo - if(debugprint)print*,'sample ',VarName,' = ',avgcfrach(isa,jsa) - -! ave low cloud fraction using nemsio - VarName='tcdc_avelcl' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgcfracl) -! where(avgcfracl /= spval)avgcfracl=avgcfracl/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgcfracl(i,j) /= spval) avgcfracl(i,j) = avgcfracl(i,j) * 0.01 - enddo - enddo - if(debugprint)print*,'sample ',VarName,' = ',avgcfracl(isa,jsa) - -! ave middle cloud fraction using nemsio - VarName='tcdc_avemcl' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgcfracm) -! where(avgcfracm /= spval)avgcfracm=avgcfracm/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgcfracm(i,j) /= spval) avgcfracm(i,j) = avgcfracm(i,j) * 0.01 - enddo - enddo - if(debugprint)print*,'sample ',VarName,' = ',avgcfracm(isa,jsa) - -! inst convective cloud fraction using nemsio - VarName='tcdccnvcl' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,cnvcfr) -! where(cnvcfr /= spval)cnvcfr=cnvcfr/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (cnvcfr(i,j) /= spval) cnvcfr (i,j)= cnvcfr(i,j) * 0.01 - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',cnvcfr(isa,jsa) - -! slope type using nemsio - VarName='sltyp' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,buf) -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i=1,im - if (buf(i,j) < spval) then - islope(i,j) = nint(buf(i,j)) - else - islope(i,j) = 0 - endif - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',islope(isa,jsa) - -! plant canopy sfc wtr in m - VarName='cnwat' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,cmc) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (cmc(i,j) /= spval) cmc(i,j) = cmc(i,j) * 0.001 - if (sm(i,j) /= 0.0) cmc(i,j) = spval - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',cmc(isa,jsa) - -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - grnflx(i,j) = spval ! GFS does not have inst ground heat flux - enddo - enddo - -! frozen precip fraction using nemsio - VarName='cpofp' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sr) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if(sr(i,j) /= spval) then -!set range within (0,1) - sr(i,j)=min(1.,max(0.,sr(i,j))) - endif - enddo - enddo - -! sea ice skin temperature - VarName='tisfc' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,ti) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sice(i,j) == spval .or. sice(i,j) == 0.) ti(i,j)=spval - enddo - enddo - -! vegetation fraction in fraction. using nemsio - VarName='veg' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,vegfrc) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (vegfrc(i,j) /= spval) then - vegfrc(i,j) = vegfrc(i,j) * 0.01 - else - vegfrc(i,j) = 0.0 - endif - enddo - enddo -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) vegfrc(i,j) = spval - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',vegfrc(isa,jsa) - -! GFS doesn not yet output soil layer thickness, assign SLDPTH to be the same as nam - - SLDPTH(1) = 0.10 - SLDPTH(2) = 0.3 - SLDPTH(3) = 0.6 - SLDPTH(4) = 1.0 - -! liquid volumetric soil mpisture in fraction using nemsio - VarName='soill1' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sh2o(1,jsta_2l,1)) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) sh2o(i,j,1) = spval - enddo - enddo - if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,1) - - VarName='soill2' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sh2o(1,jsta_2l,2)) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) sh2o(i,j,2) = spval - enddo - enddo - if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,2) - - VarName='soill3' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sh2o(1,jsta_2l,3)) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) sh2o(i,j,3) = spval - enddo - enddo - if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,3) - - VarName='soill4' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sh2o(1,jsta_2l,4)) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) sh2o(i,j,4) = spval - enddo - enddo - if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,4) - -! volumetric soil moisture using nemsio - VarName='soilw1' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,smc(1,jsta_2l,1)) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) smc(i,j,1) = spval - enddo - enddo - if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,1) - - VarName='soilw2' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,smc(1,jsta_2l,2)) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) smc(i,j,2) = spval - enddo - enddo - if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,2) - - VarName='soilw3' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,smc(1,jsta_2l,3)) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) smc(i,j,3) = spval - enddo - enddo - if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,3) - - VarName='soilw4' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,smc(1,jsta_2l,4)) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) smc(i,j,4) = spval - enddo - enddo - if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,4) - -! soil temperature using nemsio - VarName='soilt1' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,stc(1,jsta_2l,1)) -! mask open water areas, combine with sea ice tmp -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,1) = spval - !if (sm(i,j) /= 0.0) stc(i,j,1) = spval - enddo - enddo - if(debugprint)print*,'sample l','stc',' = ',1,stc(isa,jsa,1) - - VarName='soilt2' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,stc(1,jsta_2l,2)) -! mask open water areas, combine with sea ice tmp -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,2) = spval - !if (sm(i,j) /= 0.0) stc(i,j,2) = spval - enddo - enddo - if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,2) - - VarName='soilt3' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,stc(1,jsta_2l,3)) -! mask open water areas, combine with sea ice tmp -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,3) = spval - !if (sm(i,j) /= 0.0) stc(i,j,3) = spval - enddo - enddo - if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,3) - - VarName='soilt4' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,stc(1,jsta_2l,4)) -! mask open water areas, combine with sea ice tmp -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,4) = spval - !if (sm(i,j) /= 0.0) stc(i,j,4) = spval - enddo - enddo - if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,4) - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - acfrcv(i,j) = spval ! GFS does not output time averaged convective and strat cloud fraction, set acfrcv to spval, ncfrcv to 1 - ncfrcv(i,j) = 1.0 - acfrst(i,j) = spval ! GFS does not output time averaged cloud fraction, set acfrst to spval, ncfrst to 1 - ncfrst(i,j) = 1.0 - bgroff(i,j) = spval ! GFS does not have UNDERGROUND RUNOFF - rlwtoa(i,j) = spval ! GFS does not have inst model top outgoing longwave - enddo - enddo -! trdlw(i,j) = 6.0 - ardlw = 1.0 ! GFS incoming sfc longwave has been averaged over 6 hr bucket, set ARDLW to 1 - -! time averaged incoming sfc longwave - VarName='dlwrf_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,alwin) - -! inst incoming sfc longwave - VarName='dlwrf' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,rlwin) - -! time averaged outgoing sfc longwave - VarName='ulwrf_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,alwout) -! inst outgoing sfc longwave - VarName='ulwrf' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,radot) - -! where(alwout /= spval) alwout=-alwout ! CLDRAD puts a minus sign before gribbing -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (alwout(i,j) /= spval) alwout(i,j) = -alwout(i,j) - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,alwout(isa,jsa) - -! time averaged outgoing model top longwave using gfsio - VarName='ulwrf_avetoa' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,alwtoa) -! if(debugprint)print*,'sample l',VarName,' = ',1,alwtoa(isa,jsa) - -! GFS incoming sfc longwave has been averaged, set ARDLW to 1 - ardsw=1.0 -! trdsw=6.0 - -! time averaged incoming sfc shortwave - VarName='dswrf_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,aswin) -! if(debugprint)print*,'sample l',VarName,' = ',1,aswin(isa,jsa) - -! inst incoming sfc shortwave - VarName='dswrf' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,rswin) - -! inst incoming clear sky sfc shortwave - VarName='csdlf' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,rswinc) - -! time averaged incoming sfc uv-b using getgb - VarName='duvb_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,auvbin) -! if(debugprint)print*,'sample l',VarName,' = ',1,auvbin(isa,jsa) - -! time averaged incoming sfc clear sky uv-b using getgb - VarName='cduvb_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,auvbinc) -! if(debugprint)print*,'sample l',VarName,' = ',1,auvbinc(isa,jsa) - -! time averaged outgoing sfc shortwave using gfsio - VarName='uswrf_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,aswout) -! where(aswout /= spval) aswout=-aswout ! CLDRAD puts a minus sign before gribbing -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (aswout(i,j) /= spval) aswout(i,j) = -aswout(i,j) - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,aswout(isa,jsa) - -! inst outgoing sfc shortwave using gfsio - VarName='uswrf' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,rswout) - -! time averaged model top incoming shortwave - VarName='dswrf_avetoa' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,aswintoa) -! if(debugprint)print*,'sample l',VarName,' = ',1,aswintoa(isa,jsa) - -! time averaged model top outgoing shortwave - VarName='uswrf_avetoa' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,aswtoa) -! if(debugprint)print*,'sample l',VarName,' = ',1,aswtoa(isa,jsa) - -! time averaged surface sensible heat flux, multiplied by -1 because wrf model flux -! has reversed sign convention using gfsio - VarName='shtfl_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sfcshx) -! where (sfcshx /= spval)sfcshx=-sfcshx -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sfcshx(i,j) /= spval) sfcshx(i,j) = -sfcshx(i,j) - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,sfcshx(isa,jsa) - -! inst surface sensible heat flux - VarName='shtfl' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,twbs) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (twbs(i,j) /= spval) twbs(i,j) = -twbs(i,j) - enddo - enddo - -! GFS surface flux has been averaged, set ASRFC to 1 - asrfc=1.0 -! tsrfc=6.0 - -! time averaged surface latent heat flux, multiplied by -1 because wrf model flux -! has reversed sign vonvention using gfsio - VarName='lhtfl_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sfclhx) -! where (sfclhx /= spval)sfclhx=-sfclhx -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sfclhx(i,j) /= spval) sfclhx(i,j) = -sfclhx(i,j) - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,sfclhx(isa,jsa) - -! inst surface latent heat flux - VarName='lhtfl' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,qwbs) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (qwbs(i,j) /= spval) qwbs(i,j) = -qwbs(i,j) - enddo - enddo - - if(me==0)print*,'rdaod= ',rdaod -! inst aod550 optical depth - if(rdaod) then - VarName='aod550' - call read_netcdf_2d_scatter(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,aod550) - - VarName='du_aod550' - call read_netcdf_2d_scatter(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,du_aod550) - - VarName='ss_aod550' - call read_netcdf_2d_scatter(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,ss_aod550) - - VarName='su_aod550' - call read_netcdf_2d_scatter(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,su_aod550) - - VarName='oc_aod550' - call read_netcdf_2d_scatter(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,oc_aod550) - - VarName='bc_aod550' - call read_netcdf_2d_scatter(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,bc_aod550) - end if - -! time averaged ground heat flux using nemsio - VarName='gflux_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,subshx) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) subshx(i,j) = spval - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,subshx(isa,jsa) - -! inst ground heat flux using nemsio - VarName='gflux' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,grnflx) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) grnflx(i,j) = spval - enddo - enddo - -! time averaged zonal momentum flux using gfsio - VarName='uflx_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sfcux) -! if(debugprint)print*,'sample l',VarName,' = ',1,sfcux(isa,jsa) - -! time averaged meridional momentum flux using nemsio - VarName='vflx_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sfcvx) -! if(debugprint)print*,'sample l',VarName,' = ',1,sfcvx(isa,jsa) - -! dong read in inst surface flux -! inst zonal momentum flux using gfsio -! VarName='uflx' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sfcuxi) -! if(debugprint)print*,'sample l',VarName,' = ',1,sfcuxi(isa,jsa) - -! inst meridional momentum flux using nemsio -! VarName='vflx' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sfcvxi) -! if(debugprint)print*,'sample l',VarName,' = ',1,sfcvxi(isa,jsa) - - -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - sfcuvx(i,j) = spval ! GFS does not use total momentum flux - enddo - enddo - -! time averaged zonal gravity wave stress using nemsio - VarName='u-gwd_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,gtaux) -! if(debugprint)print*,'sample l',VarName,' = ',1,gtaux(isa,jsa) - -! time averaged meridional gravity wave stress using getgb - VarName='v-gwd_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,gtauy) -! if(debugprint)print*,'sample l',VarName,' = ',1,gtauy(isa,jsa) - -! time averaged accumulated potential evaporation - VarName='pevpr_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgpotevp) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) avgpotevp(i,j) = spval - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,potevp(isa,jsa) - -! inst potential evaporation - VarName='pevpr' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,potevp) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) potevp(i,j) = spval - enddo - enddo - - do l=1,lm -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im -! GFS does not have temperature tendency due to long wave radiation - rlwtt(i,j,l) = spval -! GFS does not have temperature tendency due to short wave radiation - rswtt(i,j,l) = spval -! GFS does not have temperature tendency due to latent heating from convection - tcucn(i,j,l) = spval - tcucns(i,j,l) = spval -! GFS does not have temperature tendency due to latent heating from grid scale - train(i,j,l) = spval - enddo - enddo - enddo - -! set avrain to 1 - avrain=1.0 - avcnvc=1.0 - theat=6.0 ! just in case GFS decides to output T tendency - -! 10 m u using nemsio - VarName='ugrd10m' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,u10) - - do j=jsta,jend - do i=1,im - u10h(i,j)=u10(i,j) - end do - end do -! if(debugprint)print*,'sample l',VarName,' = ',1,u10(isa,jsa) - -! 10 m v using gfsio - VarName='vgrd10m' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,v10) - - do j=jsta,jend - do i=1,im - v10h(i,j)=v10(i,j) - end do - end do -! if(debugprint)print*,'sample l',VarName,' = ',1,v10(isa,jsa) - -! vegetation type, it's in GFS surface file, hopefully will merge into gfsio soon - VarName='vtype' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,buf) -! where (buf /= spval) -! ivgtyp=nint(buf) -! elsewhere -! ivgtyp=0 !need to feed reasonable value to crtm -! end where -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i=1,im - if (buf(i,j) < spval) then - ivgtyp(i,j) = nint(buf(i,j)) - else - ivgtyp(i,j) = 0 - endif - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,ivgtyp(isa,jsa) - -! soil type, it's in GFS surface file, hopefully will merge into gfsio soon - VarName='sotyp' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,buf) - VcoordName='sfc' - l=1 -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i=1,im - if (buf(i,j) < spval) then - isltyp(i,j) = nint(buf(i,j)) - else - isltyp(i,j) = 0 !need to feed reasonable value to crtm - endif - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,isltyp(isa,jsa) - -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - smstav(i,j) = spval ! GFS does not have soil moisture availability -! smstot(i,j) = spval ! GFS does not have total soil moisture - sfcevp(i,j) = spval ! GFS does not have accumulated surface evaporation - acsnow(i,j) = spval ! GFS does not have averaged accumulated snow - acsnom(i,j) = spval ! GFS does not have snow melt -! sst(i,j) = spval ! GFS does not have sst???? - thz0(i,j) = ths(i,j) ! GFS does not have THZ0, use THS to substitute - qz0(i,j) = spval ! GFS does not output humidity at roughness length - uz0(i,j) = spval ! GFS does not output u at roughness length - vz0(i,j) = spval ! GFS does not output humidity at roughness length - enddo - enddo - do l=1,lm -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - EL_PBL(i,j,l) = spval ! GFS does not have mixing length - exch_h(i,j,l) = spval ! GFS does not output exchange coefficient - enddo - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,thz0(isa,jsa) - -! retrieve inst convective cloud top, GFS has cloud top pressure instead of index, -! will need to modify CLDRAD.f to use pressure directly instead of index -! VarName='pres' -! VcoordName='convect-cld top' -! l=1 -! if(debugprint)print*,'sample l',VarName,' = ',1,ptop(isa,jsa) - VarName='prescnvclt' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,ptop) - - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - htop(i,j) = spval - if(ptop(i,j) <= 0.0) ptop(i,j) = spval - enddo - enddo - do j=jsta,jend - do i=1,im - if(ptop(i,j) < spval)then - do l=1,lm - if(ptop(i,j) <= pmid(i,j,l))then - htop(i,j) = l -! if(i==ii .and. j==jj)print*,'sample ptop,pmid pmid-1,pint= ', & -! ptop(i,j),pmid(i,j,l),pmid(i,j,l-1),pint(i,j,l),htop(i,j) - exit - end if - end do - end if - end do - end do - -! retrieve inst convective cloud bottom, GFS has cloud top pressure instead of index, -! will need to modify CLDRAD.f to use pressure directly instead of index - VarName='prescnvclb' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,pbot) -! if(debugprint)print*,'sample l',VarName,VcoordName,' = ',1,pbot(isa,jsa) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - hbot(i,j) = spval - if(pbot(i,j) <= 0.0) pbot(i,j) = spval - enddo - enddo - do j=jsta,jend - do i=1,im -! if(.not.lb(i,j))print*,'false bitmask for pbot at ' -! + ,i,j,pbot(i,j) - if(pbot(i,j) < spval)then - do l=lm,1,-1 - if(pbot(i,j) >= pmid(i,j,l)) then - hbot(i,j) = l -! if(i==ii .and. j==jj)print*,'sample pbot,pmid= ', & -! pbot(i,j),pmid(i,j,l),hbot(i,j) - exit - end if - end do - end if - end do - end do - if(debugprint)print*,'sample hbot = ',hbot(isa,jsa) -! retrieve time averaged low cloud top pressure using nemsio - VarName='pres_avelct' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,ptopl) -! if(debugprint)print*,'sample l',VarName,' = ',1,ptopl(isa,jsa) - -! retrieve time averaged low cloud bottom pressure using nemsio - VarName='pres_avelcb' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,pbotl) -! if(debugprint)print*,'sample l',VarName,' = ',1,pbotl(isa,jsa) - -! retrieve time averaged low cloud top temperature using nemsio - VarName='tmp_avelct' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,Ttopl) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttopl(isa,jsa) - -! retrieve time averaged middle cloud top pressure using nemsio - VarName='pres_avemct' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,ptopm) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,ptopm(isa,jsa) - -! retrieve time averaged middle cloud bottom pressure using nemsio - VarName='pres_avemcb' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,pbotm) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,pbotm(isa,jsa) - -! retrieve time averaged middle cloud top temperature using nemsio - VarName='tmp_avemct' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,Ttopm) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttopm(isa,jsa) - -! retrieve time averaged high cloud top pressure using nemsio ********* - VarName='pres_avehct' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,ptoph) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,ptoph(isa,jsa) - -! retrieve time averaged high cloud bottom pressure using nemsio - VarName='pres_avehcb' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,pboth) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,pboth(isa,jsa) - -! retrieve time averaged high cloud top temperature using nemsio - VarName='tmp_avehct' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,Ttoph) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttoph(isa,jsa) - -! retrieve boundary layer cloud cover using nemsio - VarName='tcdc_avebndcl' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,pblcfr) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,pblcfr(isa,jsa) -! where (pblcfr /= spval)pblcfr=pblcfr/100. ! convert to fraction -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i=1,im - if (pblcfr(i,j) < spval) pblcfr(i,j) = pblcfr(i,j) * 0.01 - enddo - enddo - -! retrieve cloud work function - VarName='cwork_aveclm' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,cldwork) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,cldwork(isa,jsa) - -! accumulated total (base+surface) runoff - VarName='watr_acc' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,runoff) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) runoff(i,j) = spval - enddo - enddo -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,runoff(isa,jsa) - -! retrieve shelter max temperature using nemsio - VarName='tmax_max2m' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,maxtshltr) - -! retrieve shelter min temperature using nemsio - VarName='tmin_min2m' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,mintshltr) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', & -! 1,mintshltr(im/2,(jsta+jend)/2) - -! retrieve shelter max RH -! VarName='rh02max' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,maxrhshltr) - -! retrieve shelter min temperature using nemsio -! VarName='rh02min' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,minrhshltr) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', & -! 1,mintshltr(im/2,(jsta+jend)/2) - -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - MAXRHSHLTR(i,j) = SPVAL - MINRHSHLTR(i,j) = SPVAL - enddo - enddo - -! retrieve ice thickness using nemsio - VarName='icetk' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,dzice) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,dzice(isa,jsa) - -! retrieve wilting point using nemsio - VarName='wilt' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,smcwlt) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) smcwlt(i,j) = spval - enddo - enddo -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,smcwlt(isa,jsa) - -! retrieve sunshine duration using nemsio - VarName='sunsd_acc' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,suntime) - -! retrieve field capacity using nemsio - VarName='fldcp' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,fieldcapa) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) fieldcapa(i,j) = spval - enddo - enddo -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,fieldcapa(isa,jsa) - -! retrieve time averaged surface visible beam downward solar flux - VarName='vbdsf_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avisbeamswin) - VcoordName='sfc' - l=1 - -! retrieve time averaged surface visible diffuse downward solar flux - VarName='vddsf_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avisdiffswin) - -! retrieve time averaged surface near IR beam downward solar flux - VarName='nbdsf_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,airbeamswin) - -! retrieve time averaged surface near IR diffuse downward solar flux - VarName='nddsf_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,airdiffswin) - -! retrieve time averaged surface clear sky outgoing LW - VarName='csulf' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,alwoutc) - -! retrieve time averaged TOA clear sky outgoing LW - VarName='csulftoa' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,alwtoac) - -! retrieve time averaged surface clear sky outgoing SW - VarName='csusf' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,aswoutc) - -! retrieve time averaged TOA clear sky outgoing LW - VarName='csusftoa' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,aswtoac) - -! retrieve time averaged surface clear sky incoming LW - VarName='csdlf' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,alwinc) - -! retrieve time averaged surface clear sky incoming SW - VarName='csdsf' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,aswinc) - -! retrieve shelter max specific humidity using nemsio - VarName='spfhmax_max2m' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,maxqshltr) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', -! 1,maxqshltr(isa,jsa) - -! retrieve shelter min temperature using nemsio - VarName='spfhmin_min2m' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,minqshltr) - -! retrieve storm runoff using nemsio - VarName='ssrun_acc' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,SSROFF) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) ssroff(i,j) = spval - enddo - enddo - -! retrieve direct soil evaporation - VarName='evbs_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgedir) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) avgedir(i,j) = spval - enddo - enddo - -! retrieve CANOPY WATER EVAP - VarName='evcw_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgecan) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) avgecan(i,j) = spval - enddo - enddo - -! retrieve PLANT TRANSPIRATION - VarName='trans_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgetrans) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) avgetrans(i,j) = spval - enddo - enddo - -! retrieve snow sublimation - VarName='sbsno_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgesnow) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j)==1.0 .and. sice(i,j)==0.) avgesnow(i,j)=spval - enddo - enddo - -! retrive total soil moisture - VarName='soilm' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,smstot) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) smstot(i,j) = spval - enddo - enddo - -! retrieve snow phase change heat flux - VarName='snohf' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,snopcx) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) snopcx(i,j) = spval - enddo - enddo - -! GFS does not have deep convective cloud top and bottom fields - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - HTOPD(i,j) = SPVAL - HBOTD(i,j) = SPVAL - HTOPS(i,j) = SPVAL - HBOTS(i,j) = SPVAL - CUPPT(i,j) = SPVAL - enddo - enddo - -! done with flux file, close it for now - Status=nf90_close(ncid2d) -! deallocate(tmp,recname,reclevtyp,reclev) - -! pos east -! call collect_loc(gdlat,dummy) -! if(me == 0)then -! latstart = nint(dummy(1,1)*gdsdegr) -! latlast = nint(dummy(im,jm)*gdsdegr) -! print*,'laststart,latlast B bcast= ',latstart,latlast,'gdsdegr=',gdsdegr,& -! 'dummy(1,1)=',dummy(1,1),dummy(im,jm),'gdlat=',gdlat(1,1) -! end if -! call mpi_bcast(latstart,1,MPI_INTEGER,0,mpi_comm_comp,irtn) -! call mpi_bcast(latlast,1,MPI_INTEGER,0,mpi_comm_comp,irtn) -! write(6,*) 'laststart,latlast,me A calling bcast=',latstart,latlast,me -! call collect_loc(gdlon,dummy) -! if(me == 0)then -! lonstart = nint(dummy(1,1)*gdsdegr) -! lonlast = nint(dummy(im,jm)*gdsdegr) -! end if -! call mpi_bcast(lonstart,1,MPI_INTEGER,0,mpi_comm_comp,irtn) -! call mpi_bcast(lonlast, 1,MPI_INTEGER,0,mpi_comm_comp,irtn) - -! write(6,*)'lonstart,lonlast A calling bcast=',lonstart,lonlast -! - -! generate look up table for lifted parcel calculations - - THL = 210. - PLQ = 70000. - pt_TBL = 10000. ! this is for 100 hPa added by Moorthi - - CALL TABLE(PTBL,TTBL,PT_TBL, & - RDQ,RDTH,RDP,RDTHE,PL,THL,QS0,SQS,STHE,THE0) - - CALL TABLEQ(TTBLQ,RDPQ,RDTHEQ,PLQ,THL,STHEQ,THE0Q) - -! -! - IF(ME == 0)THEN - WRITE(6,*)' SPL (POSTED PRESSURE LEVELS) BELOW: ' - WRITE(6,51) (SPL(L),L=1,LSM) - 50 FORMAT(14(F4.1,1X)) - 51 FORMAT(8(F8.1,1X)) - ENDIF -! -!$omp parallel do private(l) - DO L = 1,LSM - ALSL(L) = LOG(SPL(L)) - END DO -! -!HC WRITE IGDS OUT FOR WEIGHTMAKER TO READ IN AS KGDSIN - if(me == 0)then - print*,'writing out igds' - igdout = 110 -! open(igdout,file='griddef.out',form='unformatted' -! + ,status='unknown') - if(maptype == 1)THEN ! Lambert conformal - WRITE(igdout)3 - WRITE(6,*)'igd(1)=',3 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)8 - WRITE(igdout)CENLON - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)0 - WRITE(igdout)64 - WRITE(igdout)TRUELAT2 - WRITE(igdout)TRUELAT1 - WRITE(igdout)255 - ELSE IF(MAPTYPE == 2)THEN !Polar stereographic - WRITE(igdout)5 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)8 - WRITE(igdout)CENLON - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)0 - WRITE(igdout)64 - WRITE(igdout)TRUELAT2 !Assume projection at +-90 - WRITE(igdout)TRUELAT1 - WRITE(igdout)255 - ! Note: The calculation of the map scale factor at the standard - ! lat/lon and the PSMAPF - ! Get map factor at 60 degrees (N or S) for PS projection, which will - ! be needed to correctly define the DX and DY values in the GRIB GDS - if (TRUELAT1 < 0.) THEN - LAT = -60. - else - LAT = 60. - end if - - CALL MSFPS (LAT,TRUELAT1*0.001,PSMAPF) - - ELSE IF(MAPTYPE == 3) THEN !Mercator - WRITE(igdout)1 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)8 - WRITE(igdout)latlast - WRITE(igdout)lonlast - WRITE(igdout)TRUELAT1 - WRITE(igdout)0 - WRITE(igdout)64 - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)255 - ELSE IF(MAPTYPE == 0 .OR. MAPTYPE == 203)THEN !A STAGGERED E-GRID - WRITE(igdout)203 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)136 - WRITE(igdout)CENLAT - WRITE(igdout)CENLON - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)64 - WRITE(igdout)0 - WRITE(igdout)0 - WRITE(igdout)0 - END IF - end if -! -! - - RETURN - END - diff --git a/sorc/ncep_post.fd/INITPOST_NEMS.f b/sorc/ncep_post.fd/INITPOST_NEMS.f deleted file mode 100644 index 39459701f..000000000 --- a/sorc/ncep_post.fd/INITPOST_NEMS.f +++ /dev/null @@ -1,2851 +0,0 @@ -!> @file -! . . . -!> SUBPROGRAM: INITPOST INITIALIZE POST FOR RUN -!! PRGRMMR: Hui-Ya Chuang DATE: 2008-03-26 -!! -!! ABSTRACT: THIS ROUTINE INITIALIZES CONSTANTS AND -!! VARIABLES AT THE START OF AN NEMS MODEL OR POST -!! PROCESSOR RUN. -!! -!! REVISION HISTORY -!! 21-03-11 Bo Cui - change local arrays to dimension (im,jsta:jend) -!! -!! USAGE: CALL INITPOST_NEMS -!! INPUT ARGUMENT LIST: -!! NREC -!! NFILE -!! -!! OUTPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - CTLBLK -!! LOOKUP -!! SOILDEPTH -!! -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : CRAY C-90 -!! - SUBROUTINE INITPOST_NEMS(NREC,nfile) - - use vrbls3d, only: t, q, uh, vh, q2, cwm, f_ice, f_rain, f_rimef, cfr, pint,& - pint, alpint, pmid, pmidv, zint, zmid, wh, rlwtt, rswtt,& - ttnd, tcucn, train, el_pbl, exch_h, omga, qqni, qqnr, qqw, qqi, & - qqr, qqs, qqg, REF_10CM, radius_cloud, radius_ice, radius_snow, & - extcof55, aextc55 - use vrbls2d, only: f, pd, fis, pblh, mixht, ustar, z0, ths, qs, twbs, qwbs, prec,& - acprec, cuprec,ancprc, lspa, sno, snoavg, psfcavg, t10avg, t10m, akhsavg, akmsavg,& - refd_max, w_up_max, w_dn_max, up_heli_max, si, cldefi, th10, q10, pshltr,& - tshltr, qshltr, maxtshltr, mintshltr, maxrhshltr, minrhshltr, akhs, akms, albase,& - albedo, czen, cfracl, cfracm, islope, cmc, grnflx, pctsno, soiltb, vegfrc,& - acfrcv, acfrst, ssroff, bgroff, czmean, mxsnal, radot, sigt4, tg, sr, cfrach,& - rlwin, rlwtoa, alwin, alwout, alwtoa, rswin, rswinc, rswout, aswin,aswout,& - aswtoa, sfcshx, sfclhx, subshx, snopcx, sfcuvx, potevp, ncfrcv, ncfrst, u10h,& - u10, v10h, v10, u10max, v10max, smstav, smstot, sfcevp, ivgtyp, acsnow, acsnom,& - sst, thz0, qz0, uz0, vz0, htop, isltyp, sfcexc, hbot, htopd, htops, cuppt, cprate,& - hbotd, hbots, prate_max, fprate_max - use soil, only: sldpth, sh2o, smc, stc - use masks, only: lmv, lmh, htm, vtm, dx, dy, hbm2, gdlat, gdlon, sm, sice - use kinds, only: i_llong - use wrf_io_flags_mod, only: - use params_mod, only: pi, dtr, g, d608, rd,tfrz - use lookup_mod, only: thl, plq, ptbl, ttbl, rdq, rdth, rdp, rdthe, pl, qs0, sqs, sthe, the0,& - ttblq, rdpq, rdtheq, stheq, the0q - use ctlblk_mod, only: me, mpi_comm_comp, global, icnt, idsp, jsta, ihrst, imin, idat, sdat,& - ifhr, ifmin, filename, restrt, imp_physics, isf_surface_physics, icu_physics, jend,& - dt, spval, gdsdegr, grib, pdtop, pt, tmaxmin, nsoil, lp1, jend_m, nprec, nphs, avrain,& - avcnvc, ardlw, ardsw, asrfc, novegtype, spl, lsm, dtq2, tsrfc, trdlw, trdsw, theat, tclod,& - tprec, alsl, lm , im, jm, jsta_2l, jend_2u, ivegsrc, pthresh - use gridspec_mod, only: dyval, dxval, cenlat, cenlon, maptype, gridtype, latstart, latlast, latnw,& - latse, lonstart, lonlast, lonnw, lonse, latstartv, latlastv, cenlatv, lonstartv,& - lonlastv, cenlonv - use nemsio_module, only: nemsio_gfile, nemsio_getfilehead, nemsio_close, nemsio_getheadvar - use upp_math, only: h2u -! -! INCLUDE/SET PARAMETERS. - implicit none -! - type(nemsio_gfile),intent(inout) :: nfile -! - INCLUDE "mpif.h" -! This version of INITPOST shows how to initialize, open, read from, and -! close a NetCDF dataset. In order to change it to read an internal (binary) -! dataset, do a global replacement of _ncd_ with _int_. - - character(len=20) :: VarName - character(len=20) :: VcoordName - integer :: Status - character startdate*19,SysDepInfo*80,cgar*1 - character startdate2(19)*4 -! -! NOTE: SOME INTEGER VARIABLES ARE READ INTO DUMMY ( A REAL ). THIS IS OK -! AS LONG AS REALS AND INTEGERS ARE THE SAME SIZE. -! -! ALSO, EXTRACT IS CALLED WITH DUMMY ( A REAL ) EVEN WHEN THE NUMBERS ARE -! INTEGERS - THIS IS OK AS LONG AS INTEGERS AND REALS ARE THE SAME SIZE. - logical, parameter :: debugprint = .false. -! logical, parameter :: debugprint = .true. - logical :: convert_rad_to_deg=.false. -! logical global -! CHARACTER BLANK*4 - integer nfhour ! forecast hour from nems io file - INTEGER IDATE(8),JDATE(8) -! -! DECLARE VARIABLES. -! - REAL FACT,tsph,tstart - REAL RINC(5) - REAL ETA1(LM+1), ETA2(LM+1) - REAL GARB - REAL DUM1D (LM+1) - REAL DUMMY ( IM, JM ) - REAL DUMMY2 ( IM, JM ) - real, allocatable :: fi(:,:,:) - - integer ibuf(im,jsta_2l:jend_2u) - real buf(im,jsta_2l:jend_2u) - character*8,allocatable:: recname(:) - character*16,allocatable :: reclevtyp(:) - integer,allocatable:: reclev(:) - real, allocatable:: bufy(:) - real, allocatable:: glat1d(:),glon1d(:) -!jw - integer ii,jj,js,je,jev,iyear,imn,iday,itmp,ioutcount,istatus, & - nsrfc,nrdlw,nrdsw,nheat,nclod, & - iunit,nrec,I,J,L, iret,nframe,impf,jmpf,nframed2, & - igdout,ll,n,im1,jm1,iim1,item -! -! DATA BLANK/' '/ -! -!*********************************************************************** -! START INIT HERE. -! - if(me==0)WRITE(6,*)'INITPOST: ENTER INITPOST' -! -! -! STEP 1. READ MODEL OUTPUT FILE -! -!*** -! LMH always = LM for sigma-type vert coord -! LMV always = LM for sigma-type vert coord - - do j = jsta_2l, jend_2u - do i = 1, im - LMV ( i, j ) = lm - LMH ( i, j ) = lm - end do - end do - -! HTM VTM all 1 for sigma-type vert coord - - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - HTM ( i, j, l ) = 1.0 - VTM ( i, j, l ) = 1.0 - end do - end do - end do - -! The end j row is going to be jend_2u for all variables except for V. - JS=JSTA_2L - JE=JEND_2U - IF (JEND_2U==JM) THEN - JEV=JEND_2U+1 - ELSE - JEV=JEND_2U - ENDIF -! sample print point - ii=(1+im)/2 - jj=(1+jm)/2 -! get start date - idate=0 - if (me == 0)then - print*,'nrec=',nrec - allocate(recname(nrec),reclevtyp(nrec),reclev(nrec)) - - call nemsio_getfilehead(nfile,iret=iret & - ,idate=idate(1:7),nfhour=nfhour,recname=recname & - ,reclevtyp=reclevtyp,reclev=reclev,nframe=nframe) -! if(iret/=0)print*,'error getting idate,fhour, stopping';stop - if (debugprint) then - print *,'printing an inventory of NEMS file' - do i=1,nrec - print *,'recname,reclevtyp,reclev=',trim(recname(i)),' ', & - trim(reclevtyp(i)),reclev(i) - end do - endif -! print *,'reclevtyp=',(trim(reclevtyp(i)),i=1,nrec) -! print *,'reclev=',(reclev(i),i=1,nrec) - deallocate(recname,reclevtyp,reclev) - impf=im+nframe*2 - jmpf=jm+nframe*2 -! nframed2=nframe/2 - print*,'nframe,impf,jmpf= ',nframe,impf,jmpf - allocate(glat1d(impf*jmpf),glon1d(impf*jmpf) ) - call nemsio_getfilehead(nfile,dx=glat1d & - ,dy=glon1d,iret=iret) - if(iret/=0)print*,'did not find dx dy' -! do j=1,impf*jmpf -! print*,'dx before scatter= ',j,glat1d(j) -! end do -!$omp parallel do private(i,j,item) - do j=1,jm - item = (j-1)*impf + nframe - do i=1,im - dummy(i,j) = glat1d(item+i) - dummy2(i,j) = glon1d(item+i) -! dummy(i,j)=glat1d(i-nframe,j-nframe) -! dummy2(i,j)=glon1d(i-nframe,j-nframe) - end do - end do - deallocate(glat1d,glon1d) -! latstart=nint(dummy(1,1)*1000.) -! latlast=nint(dummy(im,jm)*1000.) -! lonstart=nint(dummy2(1,1)*1000.) -! lonlast=nint(dummy2(im,jm)*1000.) -! dyval=nint((dummy(1,2)-dummy(1,1))*1000.) -! dxval=nint((dummy(2,1)-dummy(1,1))*1000.) -! cenlat=nint(dummy(ii,jj)*1000.) -! cenlon=nint(dummy2(ii,jj)*1000.) - print*,'idate before broadcast = ',(idate(i),i=1,7) - end if - call mpi_bcast(idate(1),7,MPI_INTEGER,0,mpi_comm_comp,iret) - call mpi_bcast(nfhour,1,MPI_INTEGER,0,mpi_comm_comp,iret) - call mpi_bcast(nframe,1,MPI_INTEGER,0,mpi_comm_comp,iret) -! call mpi_bcast(latstart,1,MPI_INTEGER,0,mpi_comm_comp,iret) -! call mpi_bcast(latlast,1,MPI_INTEGER,0,mpi_comm_comp,iret) -! call mpi_bcast(lonstart,1,MPI_INTEGER,0,mpi_comm_comp,iret) -! call mpi_bcast(lonlast,1,MPI_INTEGER,0,mpi_comm_comp,iret) -! call mpi_bcast(cenlat,1,MPI_INTEGER,0,mpi_comm_comp,iret) -! call mpi_bcast(cenlon,1,MPI_INTEGER,0,mpi_comm_comp,iret) -! print*, 'latstart,latlast A calling bcast=',latstart,latlast -! print*,'lonstart,lonlast A calling bcast=',lonstart,lonlast -! print*,'cenlat,cenlon A calling bcast=',cenlat,cenlon - -! if(me == 0)then -! call nemsio_getheadvar(nfile,'global',global,iret) -! if (iret /= 0) then -! print*,"global not found in file-Assigned false" -! global=.FALSE. -! end if -! end if -! call mpi_bcast(global,1,MPI_LOGICAL,0,mpi_comm_comp,iret) - -! print*,'Is this a global run ',global - IF(.not. global)THEN -! nframe=0 ! Wang added option to read without halos, so specify nframe=0 - impf=im+nframe*2 - jmpf=jm+nframe*2 -! nframed2=nframe/2 - ELSE -! nframe=1 ! - impf=im+1 ! post cut im off because it's the same as i=1 but data from model is till im - jmpf=jm -! nframed2=nframe/2 - END IF - - if (debugprint) then - print*,'impf,jmpf,nframe for reading fields = ',impf,jmpf,nframe - print*,'idate after broadcast = ',(idate(i),i=1,7) - print*,'nfhour = ',nfhour - end if - call mpi_scatterv(dummy(1,1),icnt,idsp,mpi_real & - ,dx(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,iret) - call mpi_scatterv(dummy2(1,1),icnt,idsp,mpi_real & - ,dy(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,iret) - -! print *,'before call EXCH,mype=',me,'max(gdlat)=',maxval(gdlat),'max(gdlon)=', & -! maxval(gdlon) -! CALL EXCH(gdlat(1,JSTA_2L)) -! print *,'after call EXCH,mype=',me - - iyear = idate(1) - imn = idate(2) ! ask Jun - iday = idate(3) ! ask Jun - ihrst = idate(4) - imin = idate(5) - jdate = 0 - idate = 0 -! -! read(startdate,15)iyear,imn,iday,ihrst,imin - 15 format(i4,1x,i2,1x,i2,1x,i2,1x,i2) - if (me==0) then - print*,'start yr mo day hr min =',iyear,imn,iday,ihrst,imin - print*,'processing yr mo day hr min=' & - ,idat(3),idat(1),idat(2),idat(4),idat(5) - endif -! - idate(1) = iyear - idate(2) = imn - idate(3) = iday - idate(5) = ihrst - idate(6) = imin - SDAT(1) = imn - SDAT(2) = iday - SDAT(3) = iyear - jdate(1) = idat(3) - jdate(2) = idat(1) - jdate(3) = idat(2) - jdate(5) = idat(4) - jdate(6) = idat(5) -! - -! CALL W3DIFDAT(JDATE,IDATE,2,RINC) -! ifhr=nint(rinc(2)) -! - CALL W3DIFDAT(JDATE,IDATE,0,RINC) -! - ifhr=nint(rinc(2)+rinc(1)*24.) - ifmin=nint(rinc(3)) -! if(ifhr /= nfhour)print*,'find wrong Model input file';stop - if (me==0)print*,' in INITPOST ifhr ifmin fileName=',ifhr,ifmin,trim(fileName) - -! Getting tstart - tstart=0. - -! Getiing restart - - RESTRT=.TRUE. ! set RESTRT as default -! call ext_int_get_dom_ti_integer(DataHandle,'RESTARTBIN',itmp -! + ,1,ioutcount,istatus) - -! IF(itmp < 1)THEN -! RESTRT=.FALSE. -! ELSE -! RESTRT=.TRUE. -! END IF - -! print*,'status for getting RESTARTBIN= ',istatus - -! print*,'Is this a restrt run? ',RESTRT - - IF(tstart > 1.0E-2)THEN - ifhr=ifhr+NINT(tstart) - rinc=0 - idate=0 - rinc(2)=-1.0*ifhr - call w3movdat(rinc,jdate,idate) - SDAT(1)=idate(2) - SDAT(2)=idate(3) - SDAT(3)=idate(1) - IHRST=idate(5) - print*,'new forecast hours for restrt run= ',ifhr - print*,'new start yr mo day hr min =',sdat(3),sdat(1) & - ,sdat(2),ihrst,imin - END IF - - -!KRF: Initialize extinction coef for aerosol to zero to avoid failure. -! These are not in NEMS model output, but new CALVIS_GSD methods uses -! these fields from ARW, and if not initialized here will cause failure. - extcof55=0. - aextc55=0. - -!Chuang: set default to Ferrier's MP scheme. NPS does not write MP option -!used in model to nemsio output - VarName='mp_physi' - if(me == 0)then - call nemsio_getheadvar(nfile,trim(VarName),imp_physics,iret) - if (iret /= 0) then - print*,VarName," not found in file- go to 16 character " - VarName='mp_physics' - call nemsio_getheadvar(nfile,trim(VarName),imp_physics,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned 1000" -! imp_physics=1000 ! should this line be uncommented? - Moorthi - imp_physics=5 - end if - end if - end if - call mpi_bcast(imp_physics,1,MPI_INTEGER,0,mpi_comm_comp,iret) - if(me==0)print*,'MP_PHYSICS= ',imp_physics - -! Initializes constants for Ferrier microphysics - if(imp_physics==5 .or. imp_physics==85 .or. imp_physics==95)then - CALL MICROINIT(imp_physics) - end if - - VarName='sf_surface_physi' - if(me == 0)then - call nemsio_getheadvar(nfile,trim(VarName),iSF_SURFACE_PHYSICS,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned 2 for NOAH LSM as default" - iSF_SURFACE_PHYSICS=2 - end if - end if - call mpi_bcast(iSF_SURFACE_PHYSICS,1,MPI_INTEGER,0,mpi_comm_comp,iret) - if(me==0) print*,'SF_SURFACE_PHYSICS= ',iSF_SURFACE_PHYSICS - -! IVEGSRC=1 for IGBP and 0 for USGS - VarName='IVEGSRC' - if(me == 0)then - call nemsio_getheadvar(nfile,trim(VarName),IVEGSRC,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned 1 for IGBP as default" - IVEGSRC=1 - end if - end if - call mpi_bcast(IVEGSRC,1,MPI_INTEGER,0,mpi_comm_comp,iret) - if(me==0) print*,'IVEGSRC= ',IVEGSRC - -! set novegtype based on vegetation classification - if(ivegsrc==1)then - novegtype=20 - else if(ivegsrc==0)then - novegtype=24 - end if - if(me==0) print*,'novegtype= ',novegtype - - VarName='CU_PHYSICS' - if(me == 0)then - call nemsio_getheadvar(nfile,trim(VarName),iCU_PHYSICS,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned 2 for BMJ as default" - iCU_PHYSICS=2 - end if - end if - call mpi_bcast(iCU_PHYSICS,1,MPI_INTEGER,0,mpi_comm_comp,iret) - if(me==0) print*,'CU_PHYSICS= ',iCU_PHYSICS - - - allocate(bufy(jm)) - VarName='DX' -! if(me == 0)then -! call nemsio_getheadvar(nfile,trim(VarName),bufy,iret) -! if (iret /= 0) then -! print*,VarName," not found in file-Assigned missing values" -! dx=spval -! end if -! end if -! call mpi_bcast(bufy,jm,MPI_REAL,0,mpi_comm_comp,iret) -! do j=jsta,jend -! do i=1,im -! dx(i,j)=bufy(j) -! end do -! end do - if(debugprint)print*,'sample ',VarName,' = ',dx(im/2,(jsta+jend)/2) - - VarName='DY' -! if(me == 0)then -! call nemsio_getheadvar(nfile,trim(VarName),bufy,iret) -! if (iret /= 0) then -! print*,VarName," not found in file-Assigned missing values" -! dx=spval -! end if -! end if -! call mpi_bcast(bufy,jm,MPI_REAL,0,mpi_comm_comp,iret) -! do j=jsta,jend -! do i=1,im -! dy(i,j)=bufy(j) -! end do -! end do - if(debugprint)print*,'sample ',VarName,' = ',dy(im/2,(jsta+jend)/2) - deallocate(bufy) - - VarName='dt' - if(me == 0)then - call nemsio_getheadvar(nfile,trim(VarName),garb,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned missing values" - dt=spval - else - dt=garb - end if - end if - call mpi_bcast(dt,1,MPI_REAL,0,mpi_comm_comp,iret) - - VarName='dphd' - if(me == 0)then - call nemsio_getheadvar(nfile,trim(VarName),garb,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned missing values" - dyval=spval - else - dyval=garb*gdsdegr - end if - end if - call mpi_bcast(dyval,1,MPI_REAL,0,mpi_comm_comp,iret) -! dyval=106 ! hard wire for AQ domain testing - - VarName='dlmd' - if(me == 0)then - call nemsio_getheadvar(nfile,trim(VarName),garb,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned missing values" - dxval=spval - else - dxval=garb*gdsdegr - end if - end if - call mpi_bcast(dxval,1,MPI_REAL,0,mpi_comm_comp,iret) -! dxval=124 ! hard wire for AQ domain testing - - if(me==0) print*,'DX, DY, DT=',dxval,dyval,dt - - VarName='TPH0D' - if(me == 0)then - call nemsio_getheadvar(nfile,trim(VarName),garb,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned missing values" - cenlat=spval - else - cenlat=nint(garb*gdsdegr) - end if - end if - call mpi_bcast(cenlat,1,MPI_INTEGER,0,mpi_comm_comp,iret) - - VarName='TLM0D' - if(me == 0)then - call nemsio_getheadvar(nfile,trim(VarName),garb,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned missing values" - cenlon=spval - else - if(grib=="grib2") then - cenlon=nint((garb+360.)*gdsdegr) - endif - end if - end if - call mpi_bcast(cenlon,1,MPI_INTEGER,0,mpi_comm_comp,iret) - -! VarName='TRUELAT1' -! call retrieve_index(index,VarName,varname_all,nrecs,iret) -! if (iret /= 0) then -! print*,VarName," not found in file" -! else -! call mpi_file_read_at(iunit,file_offset(index)+5*4 & -! ,garb,1,mpi_real4, mpi_status_ignore, ierr) -! if (ierr /= 0) then -! print*,"Error reading ", VarName," using MPIIO" -! else -! print*,VarName, ' from MPIIO READ= ',garb -! TRUELAT1=nint(garb*1000.) -! write(6,*) 'truelat1= ', TRUELAT1 -! end if -! end if - -! VarName='TRUELAT2' -! call retrieve_index(index,VarName,varname_all,nrecs,iret) -! if (iret /= 0) then -! print*,VarName," not found in file" -! else -! call mpi_file_read_at(iunit,file_offset(index)+5*4 & -! ,garb,1,mpi_real4, mpi_status_ignore, ierr) -! if (ierr /= 0) then -! print*,"Error reading ", VarName," using MPIIO" -! else -! print*,VarName, ' from MPIIO READ= ',garb -! TRUELAT2=nint(garb*1000.) -! write(6,*) 'truelat2= ', TRUELAT2 -! end if -! end if - -! VarName='MAP_PROJ' -! if(me == 0)then -! call nemsio_getheadvar(nfile,trim(VarName),maptype,iret) -! if (iret /= 0) then -! print*,VarName," not found in file-Assigned 1000" -! maptype=1000 -! end if -! end if -! call mpi_bcast(maptype,1,MPI_INTEGER,0,mpi_comm_comp,iret) - IF(.not. global)THEN - maptype=205 ! for Arakawa-B grid - gridtype='B' - ELSE - maptype=0 ! for global NMMB on latlon grid - gridtype='A' ! will put wind on mass point for now to make regular latlon - END IF - if(me==0) print*,'maptype and gridtype= ',maptype,gridtype - - HBM2=1.0 - - varname='glat' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,impf,jmpf,nframe,gdlat) - - call collect_loc(gdlat,dummy) -! decides whether or not to convert to degree - if(me==0)then - if(maxval(abs(dummy))0. .and. gdlon(2,jsta)<0.)then - do j=jsta,jend - gdlon(1,j) = gdlon(1,j)-360.0 - end do - end if - end if - if(debugprint)print*,'sample ',VarName,' = ',(gdlon(i,(jsta+jend)/2),i=1,im,8) - if(debugprint)print*,'max min lon=',maxval(gdlon),minval(gdlon) - call collect_loc(gdlon,dummy) - if(me==0)then - if(grib=='grib2') then - if(dummy(1,1)<0) dummy(1,1)=dummy(1,1)+360. - if(dummy(im,jm)<0) dummy(im,jm)=dummy(im,jm)+360. - endif - lonstart=nint(dummy(1,1)*gdsdegr) - lonlast=nint(dummy(im,jm)*gdsdegr) - lonnw=nint(dummy(1,jm)*gdsdegr) - lonse=nint(dummy(im,1)*gdsdegr) -! dxval=nint((dummy(2,1)-dummy(1,1))*1000.) -! dxval=124 ! hard wire for AQ domain testing - if(mod(im,2)==0)then -! cenlon=nint((dummy(ii,jj)+dummy(ii+1,jj)+dummy(ii+1,jj+1)+dummy(ii,jj+1))/4.0*1000.) - else -! cenlon=nint(dummy(ii,jj)*1000.) - end if - end if - call mpi_bcast(lonstart,1,MPI_INTEGER,0,mpi_comm_comp,iret) - call mpi_bcast(lonlast,1,MPI_INTEGER,0,mpi_comm_comp,iret) -! call mpi_bcast(dxval,1,MPI_INTEGER,0,mpi_comm_comp,iret) -! call mpi_bcast(cenlon,1,MPI_INTEGER,0,mpi_comm_comp,iret) - write(6,*)'lonstart,lonlast A calling bcast=',lonstart,lonlast - print*,'dxval, cenlon= ',dxval, cenlon - - convert_rad_to_deg=.false. - varname='vlat' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,impf,jmpf,nframe,buf) - if(debugprint)print*,'sample ',VarName,' = ',buf(im/2,(jsta+jend)/2) - if(debugprint)print*,'max min vlat=',maxval(buf),minval(buf) - call collect_loc(buf,dummy) - if(me==0)then - if(maxval(abs(dummy)) 27.0 .or. sfcevp(i,j)<1.0)print*, & -! 'bad vegtype=',i,j,sfcevp(i,j) -! end do -! end do - - where(sfcevp /= spval)IVGTYP=nint(sfcevp) - if(debugprint)print*,'sample ',VarName,' = ',IVGTYP(im/2,(jsta+jend)/2) - - VarName='SLTYP' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,impf,jmpf,nframe,sfcevp) - where(sfcevp /= spval)ISLTYP=nint(sfcevp) - if(debugprint)print*,'sample ',VarName,' = ',ISLTYP(im/2,(jsta+jend)/2) - -! call retrieve_index(index,VarName,varname_all,nrecs,iret) -! if (iret /= 0) then -! print*,VarName," not found in file-Assigned missing values" -! ISLTYP=NINT(SPVAL) -! else -! this_offset=file_offset(index+1)+(jsta_2l-1)*4*im -! this_length=im*(jend_2u-jsta_2l+1) -! call mpi_file_read_at(iunit,this_offset & -! ,isltyp,this_length,mpi_integer4, mpi_status_ignore, ierr) -! if (ierr /= 0) then -! print*,"Error reading ", VarName,"Assigned missing values" -! ISLTYP=NINT(SPVAL) -! end if -! end if - - VarName='sfcevp' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,impf,jmpf,nframe,sfcevp) - if(debugprint)print*,'sample ',VarName,' = ',sfcevp(im/2,(jsta+jend)/2) - - VarName='sfcexc' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,impf,jmpf,nframe,sfcexc) - if(debugprint)print*,'sample ',VarName,' = ',sfcexc(im/2,(jsta+jend)/2) - if(debugprint)print*,'MAX/MIN ',VarName,' = ' & - ,maxval(sfcexc),minval(sfcexc) - - VarName='acsnow' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,impf,jmpf,nframe,acsnow) - if(debugprint)print*,'sample ',VarName,' = ',acsnow(im/2,(jsta+jend)/2) - - VarName='acsnom' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,impf,jmpf,nframe,acsnom) - if(debugprint)print*,'sample ',VarName,' = ',acsnom(im/2,(jsta+jend)/2) - - VarName='tsea' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,impf,jmpf,nframe,sst) - if(debugprint)print*,'sample ',VarName,' = ',sst(im/2,(jsta+jend)/2) - -! VarName='EL_PBL' ! not in nems io yet - VarName='xlen_mix' - VcoordName='mid layer' - do l=1,lm -! ll=lm-l+1 - ll=l - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,impf,jmpf,nframe,EL_PBL(1,jsta_2l,ll)) - if(debugprint)print*,'sample l ',VarName,' = ',ll,EL_PBL(im/2,(jsta+jend)/2,ll) - end do ! do loop for l - - VarName='exch_h' - VcoordName='mid layer' - do l=1,lm -! ll=lm-l+1 - ll=l - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,impf,jmpf,nframe,exch_h(1,jsta_2l,ll)) - if(debugprint)print*,'sample l ',VarName,' = ',ll,exch_h(im/2,(jsta+jend)/2,ll) - end do ! do loop for l - - VarName='thz0' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,impf,jmpf,nframe,thz0) - if(debugprint)print*,'sample ',VarName,' = ',thz0(im/2,(jsta+jend)/2) - - VarName='qz0' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,impf,jmpf,nframe,qz0) - if(debugprint)print*,'sample ',VarName,' = ',qz0(im/2,(jsta+jend)/2) - - VarName='uz0' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,impf,jmpf,nframe,uz0) - if(debugprint)print*,'sample ',VarName,' = ',uz0(im/2,(jsta+jend)/2) - - VarName='vz0' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,impf,jmpf,nframe,vz0) - if(debugprint)print*,'sample ',VarName,' = ',vz0(im/2,(jsta+jend)/2) - -! -! Very confusing story ... -! -! Retrieve htop and hbot => They are named CNVTOP, CNVBOT in the model and -! with HBOTS,HTOPS (shallow conv) and HBOTD,HTOPD (deep conv) represent -! the 3 sets of convective cloud base/top arrays tied to the frequency -! that history files are written. -! -! IN THE *MODEL*, arrays HBOT,HTOP are similar to CNVTOP,CNVBOT but are -! used in radiation and are tied to the frequency of radiation updates. -! -! For historical reasons model arrays CNVTOP,CNVBOT are renamed HBOT,HTOP -! and manipulated throughout the post. - -! retrieve htop and hbot -! VarName='HTOP' - VarName='cnvtop' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,impf,jmpf,nframe,htop) - where(htop /= spval)htop=float(lm)-htop+1.0 -! where(htop /= spval .and. htop > lm)htop=lm*1.0 - if(debugprint)print*,'sample ',VarName,' = ',htop(im/2,(jsta+jend)/2) - -! VarName='HBOT' - VarName='cnvbot' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,impf,jmpf,nframe,hbot) - where(hbot /= spval)hbot=float(lm)-hbot+1.0 -! where(hbot /= spval .and. hbot > lm)hbot=lm*1.0 - if(debugprint)print*,'sample ',VarName,' = ',hbot(im/2,(jsta+jend)/2) - - VarName='htopd' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,impf,jmpf,nframe,htopd) - where(htopd /= spval)htopd=float(lm)-htopd+1.0 -! where(htopd /= spval .and. htopd > lm)htopd=lm*1.0 - if(debugprint)print*,'sample ',VarName,' = ',htopd(im/2,(jsta+jend)/2) - - VarName='hbotd' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,impf,jmpf,nframe,hbotd) - where(hbotd /= spval)hbotd=float(lm)-hbotd+1.0 -! where(hbotd /= spval .and. hbotd > lm)hbotd=lm*1.0 - if(debugprint)print*,'sample ',VarName,' = ',hbotd(im/2,(jsta+jend)/2) - - VarName='htops' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,impf,jmpf,nframe,htops) - where(htops /= spval)htops=float(lm)-htops+1.0 -! where(htops /= spval .and. htops > lm)htops=lm*1.0 - if(debugprint)print*,'sample ',VarName,' = ',htops(im/2,(jsta+jend)/2) - - VarName='hbots' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,impf,jmpf,nframe,hbots) - where(hbots /= spval)hbots=float(lm)-hbots+1.0 -! where(hbots /= spval .and. hbots > lm)hbots=lm*1.0 - if(debugprint)print*,'sample ',VarName,' = ',hbots(im/2,(jsta+jend)/2) - - VarName='cuppt' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,impf,jmpf,nframe,cuppt) - if(debugprint)print*,'sample ',VarName,' = ',cuppt(im/2,(jsta+jend)/2) - - VarName='cprate' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,impf,jmpf,nframe,cprate) - if(debugprint)print*,'sample ',VarName,' = ',cprate(im/2,(jsta+jend)/2) - -!!!! DONE GETTING - -!$omp parallel do private(i,j,l) - do l = 1, lm - do j = jsta, jend - do i = 1, im - IF(ABS(T(I,J,L))>1.0E-3 .and. (WH(I,J,1) < SPVAL)) & - OMGA(I,J,L) = -WH(I,J,L)*PMID(I,J,L)*G & - / (RD*T(I,J,L)*(1.+D608*Q(I,J,L))) - end do - end do - end do - - THL=210. - PLQ=70000. - - CALL TABLE(PTBL,TTBL,PT, & - RDQ,RDTH,RDP,RDTHE,PL,THL,QS0,SQS,STHE,THE0) - - CALL TABLEQ(TTBLQ,RDPQ,RDTHEQ,PLQ,THL,STHEQ,THE0Q) - -! -! - IF(ME==0)THEN - WRITE(6,*)' SPL (POSTED PRESSURE LEVELS) BELOW: ' - WRITE(6,51) (SPL(L),L=1,LSM) - 50 FORMAT(14(F4.1,1X)) - 51 FORMAT(8(F8.1,1X)) - ENDIF -! -! COMPUTE DERIVED TIME STEPPING CONSTANTS. -! -!MEB need to get DT -! DT = 120. !MEB need to get DT -! NPHS = 4 !MEB need to get physics DT - DTQ2 = DT * NPHS !MEB need to get physics DT - TSPH = 3600./DT !MEB need to get DT - - IF (PTHRESH > 0.) THEN - PTHRESH = 0.01*DTQ2/3.6E6 !-- Precip rate >= 0.01 mm/h -! PTHRESH = 0.01*DTQ2/(3600.*39.37) !-- Precip rate >= 0.01 inches/h - ENDIF - - TSRFC=float(NSRFC)/TSPH - if(me==0)write(6,*)'tsfrc ',tsrfc,nsrfc,tsph - IF(NSRFC==0)TSRFC=float(ifhr) !in case buket does not get emptied - TRDLW=float(NRDLW)/TSPH - IF(NRDLW==0)TRDLW=float(ifhr) !in case buket does not get emptied - TRDSW=float(NRDSW)/TSPH - IF(NRDSW==0)TRDSW=float(ifhr) !in case buket does not get emptied - THEAT=float(NHEAT)/TSPH - IF(NHEAT==0)THEAT=float(ifhr) !in case buket does not get emptied - TCLOD=float(NCLOD)/TSPH - IF(NCLOD==0)TCLOD=float(ifhr) !in case buket does not get emptied - TPREC=float(NPREC)/TSPH - IF(NPREC==0)TPREC=float(ifhr) !in case buket does not get emptied -! TPREC=float(ifhr) - if(me==0)print*,'TSRFC TRDLW TRDSW THEAT TCLOD TPREC= ' & - ,TSRFC, TRDLW, TRDSW, THEAT, TCLOD, TPREC -!MEB need to get DT - -!how am i going to get this information? -! 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) -!how am i going to get this information? -! -! IF(ME==0)THEN -! WRITE(6,*)' ' -! WRITE(6,*)'DERIVED TIME STEPPING CONSTANTS' -! WRITE(6,*)' NPREC,NHEAT,NSRFC : ',NPREC,NHEAT,NSRFC -! WRITE(6,*)' NCLOD,NRDSW,NRDLW : ',NCLOD,NRDSW,NRDLW -! ENDIF -! -! COMPUTE DERIVED MAP OUTPUT CONSTANTS. - DO L = 1,LSM - ALSL(L) = ALOG(SPL(L)) - END DO -! -!HC WRITE IGDS OUT FOR WEIGHTMAKER TO READ IN AS KGDSIN - if(me==0)then - print*,'writing out igds' - igdout=110 -! open(igdout,file='griddef.out',form='unformatted' -! + ,status='unknown') - IF(MAPTYPE==203)THEN !A STAGGERED E-GRID - WRITE(igdout)203 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)136 - WRITE(igdout)CENLAT - WRITE(igdout)CENLON - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)64 - WRITE(igdout)0 - WRITE(igdout)0 - WRITE(igdout)0 - WRITE(igdout)LATLAST - WRITE(igdout)LONLAST - ELSE IF(MAPTYPE==205)THEN !A STAGGERED B-GRID - WRITE(igdout)205 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)136 - WRITE(igdout)CENLAT - WRITE(igdout)CENLON - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)64 - WRITE(igdout)LATLAST - WRITE(igdout)LONLAST - WRITE(igdout)0 - WRITE(igdout)0 - WRITE(igdout)0 - END IF - open(111,file='copygb_gridnav.txt',form='formatted' & - ,status='unknown') - IF(MAPTYPE==203)THEN !A STAGGERED E-GRID - write(111,1000) 2*IM-1,JM,LATSTART,LONSTART,CENLON, & - NINT(dxval*107.),NINT(dyval*110.),CENLAT,CENLAT - ELSE IF(MAPTYPE==205)THEN !A STAGGERED B-GRID - if(grib=="grib2") then - write(111,1000) IM,JM,LATSTART/1000,LONSTART/1000,CENLON/1000, & - NINT(dxval*107.)/1000,NINT(dyval*110.)/1000, & - CENLAT/1000,CENLAT/1000, & - LATLAST/1000,LONLAST/1000 - endif - END IF -1000 format('255 3 ',2(I4,x),I6,x,I7,x,'8 ',I7,x,2(I6,x),'0 64', & - 3(x,I6),x,I7) - close(111) -! - IF (MAPTYPE==205)THEN !A STAGGERED B-GRID - open(112,file='latlons_corners.txt',form='formatted' & - ,status='unknown') - if(grib=="grib2") then - write(112,1001)LATSTART/1000,(LONSTART/1000)-360000, & - LATSE/1000, & - LONSE/1000,LATNW/1000,LONNW/1000,LATLAST/1000, & - (LONLAST/1000)-360000 - endif -1001 format(4(I6,x,I7,x)) - close(112) - ENDIF - - end if - -! close all files - call nemsio_close(nfile,iret=status) -! - if(me==0)write(0,*)'end of INIT_NEMS' - - RETURN - END diff --git a/sorc/ncep_post.fd/INITPOST_NEMS_MPIIO.f b/sorc/ncep_post.fd/INITPOST_NEMS_MPIIO.f deleted file mode 100644 index 9aed1706b..000000000 --- a/sorc/ncep_post.fd/INITPOST_NEMS_MPIIO.f +++ /dev/null @@ -1,2464 +0,0 @@ -!> @file -! . . . -!> SUBPROGRAM: INITPOST INITIALIZE POST FOR RUN -!! PRGRMMR: Hui-Ya Chuang DATE: 2008-03-26 -!! -!! ABSTRACT: THIS ROUTINE INITIALIZES CONSTANTS AND -!! VARIABLES AT THE START OF AN NEMS MODEL OR POST -!! PROCESSOR RUN. -!! -!! REVISION HISTORY -!! 21-03-11 Bo Cui - change local arrays to dimension (im,jsta:jend) -!! -!! USAGE: CALL INITPOST_NEMS -!! INPUT ARGUMENT LIST: -!! NREC -!! NFILE -!! -!! OUTPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - CTLBLK -!! LOOKUP -!! SOILDEPTH -!! -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : CRAY C-90 -!! - SUBROUTINE INITPOST_NEMS_MPIIO() - - use vrbls3d, only: t, q, uh, vh, q2, cwm, f_ice, f_rain, f_rimef, cfr, pint,& - pint, alpint, pmid, pmidv, zint, zmid, wh, rlwtt, rswtt,& - ttnd, tcucn, train, el_pbl, exch_h, omga - use vrbls2d, only: f, pd, fis, pblh, mixht, ustar, z0, ths, qs, twbs, qwbs, prec,& - acprec, cuprec,ancprc, lspa, sno, snoavg, psfcavg, t10avg, t10m, akhsavg, akmsavg,& - refd_max, w_up_max, w_dn_max, up_heli_max, si, cldefi, th10, q10, pshltr,& - tshltr, qshltr, maxtshltr, mintshltr, maxrhshltr, minrhshltr, akhs, akms, albase,& - albedo, czen, cfracl, cfracm, islope, cmc, grnflx, pctsno, soiltb, vegfrc,& - acfrcv, acfrst, ssroff, bgroff, czmean, mxsnal, radot, sigt4, tg, sr, cfrach,& - rlwin, rlwtoa, alwin, alwout, alwtoa, rswin, rswinc, rswout, aswin,aswout,& - aswtoa, sfcshx, sfclhx, subshx, snopcx, sfcuvx, potevp, ncfrcv, ncfrst, u10h,& - u10, v10h, v10, u10max, v10max, smstav, smstot, sfcevp, ivgtyp, acsnow, acsnom,& - sst, thz0, qz0, uz0, vz0, htop, isltyp, sfcexc, hbot, htopd, htops, cuppt, cprate,& - hbotd, hbots - use soil, only: sldpth, sh2o, smc, stc - use masks, only: lmv, lmh, htm, vtm, dx, dy, hbm2, gdlat, gdlon, sm, sice - use kinds, only: i_llong - use wrf_io_flags_mod, only: - use params_mod, only: pi, dtr, g, d608, rd - use lookup_mod, only: thl, plq, ptbl, ttbl, rdq, rdth, rdp, rdthe, pl, qs0, sqs, sthe, the0,& - ttblq, rdpq, rdtheq, stheq, the0q - use ctlblk_mod, only: me, mpi_comm_comp, global, icnt, idsp, jsta, ihrst, imin, idat, sdat,& - ifhr, ifmin, filename, restrt, imp_physics, isf_surface_physics, icu_physics, jend,& - dt, spval, gdsdegr, grib, pdtop, pt, tmaxmin, nsoil, lp1, jend_m, nprec, nphs, avrain,& - avcnvc, ardlw, ardsw, asrfc, novegtype, spl, lsm, dtq2, tsrfc, trdlw, trdsw, theat, tclod,& - tprec, alsl, lm , im, jm, jsta_2l, jend_2u, ivegsrc, pthresh - use gridspec_mod, only: dyval, dxval, cenlat, cenlon, maptype, gridtype, latstart, latlast, latnw,& - latse, lonstart, lonlast, lonnw, lonse, latstartv, latlastv, cenlatv, lonstartv,& - lonlastv, cenlonv -! use nemsio_module, only: nemsio_gfile, nemsio_getfilehead, nemsio_close, nemsio_getheadvar - use nemsio_module_mpi - use upp_math, only: h2u -! -! INCLUDE/SET PARAMETERS. - implicit none -! - type(nemsio_gfile) :: nfile -! - INCLUDE "mpif.h" -! This version of INITPOST shows how to initialize, open, read from, and -! close a NetCDF dataset. In order to change it to read an internal (binary) -! dataset, do a global replacement of _ncd_ with _int_. - - character(len=8) :: VarName - character(len=8) :: VcoordName - integer :: Status - integer fldsize,fldst,recn - character startdate*19,SysDepInfo*80,cgar*1 - character startdate2(19)*4 -! -! NOTE: SOME INTEGER VARIABLES ARE READ INTO DUMMY ( A REAL ). THIS IS OK -! AS LONG AS REALS AND INTEGERS ARE THE SAME SIZE. -! -! ALSO, EXTRACT IS CALLED WITH DUMMY ( A REAL ) EVEN WHEN THE NUMBERS ARE -! INTEGERS - THIS IS OK AS LONG AS INTEGERS AND REALS ARE THE SAME SIZE. - LOGICAL RUNB,SINGLRST,SUBPOST,NEST,HYDRO - LOGICAL IOOMG,IOALL - logical, parameter :: debugprint = .false. - logical fliplayer ! whether or not to flip layer - logical :: convert_rad_to_deg=.false. -! logical global - CHARACTER*32 LABEL - CHARACTER*40 CONTRL,FILALL,FILMST,FILTMP,FILTKE,FILUNV & - , FILCLD,FILRAD,FILSFC - CHARACTER*4 RESTHR - CHARACTER FNAME*80,ENVAR*50,BLANK*4 - integer nfhour ! forecast hour from nems io file - INTEGER IDATE(8),JDATE(8) -! -! DECLARE VARIABLES. -! - REAL FACT,tsph,tstart - REAL RINC(5) - REAL ETA1(LM+1), ETA2(LM+1) - REAL GARB - REAL DUM1D (LM+1) - REAL DUMMY ( IM, JM ) -! REAL DUMMY2 ( IM, JM ) - real, allocatable :: fi(:,:,:) - integer ibuf(im,jsta_2l:jend_2u) - real buf(im,jsta_2l:jend_2u) - character*8,allocatable:: recname(:) - character*8,allocatable :: reclevtyp(:) - integer,allocatable:: reclev(:) - real, allocatable:: bufy(:) - real, allocatable:: glat1d(:),glon1d(:) - real, allocatable:: tmp(:) -!jw - integer ii,jj,js,je,jev,iyear,imn,iday,itmp,ioutcount,istatus, & - nsrfc,nrdlw,nrdsw,nheat,nclod, & - iunit,nrec,I,J,L, iret,nframe,impf,jmpf,nframed2, & - igdout,ll,n,im1,jm1,iim1 -! - DATA BLANK/' '/ -! -!*********************************************************************** -! START INIT HERE. -! - WRITE(6,*)'INITPOST: ENTER INITPOST' -! -! -! STEP 1. READ MODEL OUTPUT FILE -! -!*** -! LMH always = LM for sigma-type vert coord -! LMV always = LM for sigma-type vert coord - - do j = jsta_2l, jend_2u - do i = 1, im - LMV ( i, j ) = lm - LMH ( i, j ) = lm - end do - end do - -! HTM VTM all 1 for sigma-type vert coord - - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - HTM ( i, j, l ) = 1.0 - VTM ( i, j, l ) = 1.0 - end do - end do - end do - -! The end j row is going to be jend_2u for all variables except for V. - JS=JSTA_2L - JE=JEND_2U - IF (JEND_2U==JM) THEN - JEV=JEND_2U+1 - ELSE - JEV=JEND_2U - ENDIF -! sample print point - ii=(1+im)/2 - jj=(1+jm)/2 -! initialize nemsio using mpi io module - call nemsio_init() - call nemsio_open(nfile,trim(filename),'read',mpi_comm_comp,iret=status) - if ( Status /= 0 ) then - print*,'error opening ',fileName, ' Status = ', Status ; stop - endif - call nemsio_getfilehead(nfile,iret=status,nrec=nrec) - print*,'nrec=',nrec - allocate(recname(nrec),reclevtyp(nrec),reclev(nrec)) - call nemsio_getfilehead(nfile,iret=iret & - ,recname=recname ,reclevtyp=reclevtyp,reclev=reclev) - if (me == 0)then - do i=1,nrec - print *,'recname,reclevtyp,reclev=',trim(recname(i)),' ', & - trim(reclevtyp(i)),reclev(i) - end do - end if - -! get start date - idate=0 -! if (me == 0)then - call nemsio_getfilehead(nfile,iret=iret & - ,idate=idate(1:7),nfhour=nfhour,nframe=nframe) - - impf=im+nframe*2 - jmpf=jm+nframe*2 - print*,'nframe,impf,jmpf= ',nframe,impf,jmpf - allocate(glat1d(impf*jmpf),glon1d(impf*jmpf) ) - call nemsio_getfilehead(nfile,dx=glat1d & - ,dy=glon1d,iret=iret) - if(iret/=0)print*,'did not find dx dy' - do j=jsta,jend - do i=1,im - ! dummy(i,j) = glat1d((j-1)*impf+i+nframe) - ! dummy2(i,j) = glon1d((j-1)*impf+i+nframe) - dx(i,j)= glat1d((j-1)*impf+i+nframe) - dy(i,j)= glon1d((j-1)*impf+i+nframe) - end do - end do - deallocate(glat1d,glon1d) - print*,'idate before broadcast = ',(idate(i),i=1,7) -! end if !for me=0 -! call mpi_bcast(idate(1),7,MPI_INTEGER,0,mpi_comm_comp,iret) -! call mpi_bcast(nfhour,1,MPI_INTEGER,0,mpi_comm_comp,iret) -! call mpi_bcast(nframe,1,MPI_INTEGER,0,mpi_comm_comp,iret) - - IF(.not. global)THEN - impf=im+nframe*2 - jmpf=jm+nframe*2 - ELSE - impf=im+1 ! post cut im off because it's the same as i=1 but data from model is till im - jmpf=jm - END IF - print*,'impf,jmpf,nframe for reading fields = ',impf,jmpf,nframe - print*,'idate after broadcast = ',(idate(i),i=1,7) - print*,'nfhour = ',nfhour - !call mpi_scatterv(dummy(1,1),icnt,idsp,mpi_real & - ! ,dx(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,iret) - !call mpi_scatterv(dummy2(1,1),icnt,idsp,mpi_real & - ! ,dy(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,iret) - - - iyear = idate(1) - imn = idate(2) ! ask Jun - iday = idate(3) ! ask Jun - ihrst = idate(4) - imin = idate(5) - jdate = 0 - idate = 0 -! -! read(startdate,15)iyear,imn,iday,ihrst,imin - 15 format(i4,1x,i2,1x,i2,1x,i2,1x,i2) - print*,'start yr mo day hr min =',iyear,imn,iday,ihrst,imin - print*,'processing yr mo day hr min=' & - ,idat(3),idat(1),idat(2),idat(4),idat(5) -! - idate(1) = iyear - idate(2) = imn - idate(3) = iday - idate(5) = ihrst - idate(6) = imin - SDAT(1) = imn - SDAT(2) = iday - SDAT(3) = iyear - jdate(1) = idat(3) - jdate(2) = idat(1) - jdate(3) = idat(2) - jdate(5) = idat(4) - jdate(6) = idat(5) -! - print *,' idate=',idate - print *,' jdate=',jdate -! CALL W3DIFDAT(JDATE,IDATE,2,RINC) -! ifhr=nint(rinc(2)) -! - CALL W3DIFDAT(JDATE,IDATE,0,RINC) -! - print *,' rinc=',rinc - ifhr=nint(rinc(2)+rinc(1)*24.) - print *,' ifhr=',ifhr - ifmin=nint(rinc(3)) -! if(ifhr /= nfhour)print*,'find wrong Model input file';stop - print*,' in INITPOST ifhr ifmin fileName=',ifhr,ifmin,fileName - -! Getting tstart - tstart=0. - print*,'tstart= ',tstart - -! Getiing restart - - RESTRT=.TRUE. ! set RESTRT as default -! call ext_int_get_dom_ti_integer(DataHandle,'RESTARTBIN',itmp -! + ,1,ioutcount,istatus) - -! IF(itmp < 1)THEN -! RESTRT=.FALSE. -! ELSE -! RESTRT=.TRUE. -! END IF - -! print*,'status for getting RESTARTBIN= ',istatus - -! print*,'Is this a restrt run? ',RESTRT - - IF(tstart > 1.0E-2)THEN - ifhr=ifhr+NINT(tstart) - rinc=0 - idate=0 - rinc(2)=-1.0*ifhr - call w3movdat(rinc,jdate,idate) - SDAT(1)=idate(2) - SDAT(2)=idate(3) - SDAT(3)=idate(1) - IHRST=idate(5) - print*,'new forecast hours for restrt run= ',ifhr - print*,'new start yr mo day hr min =',sdat(3),sdat(1) & - ,sdat(2),ihrst,imin - END IF - - VarName='mp_physi' - !if(me == 0)then - call nemsio_getheadvar(nfile,trim(VarName),imp_physics,iret) - if (iret /= 0) then - print*,VarName," not found in file- go to 16 character " - VarName='mp_physics' - call nemsio_getheadvar(nfile,trim(VarName),imp_physics,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned 1000" - imp_physics=1000 - end if - end if - !end if - !call mpi_bcast(imp_physics,1,MPI_INTEGER,0,mpi_comm_comp,iret) - print*,'MP_PHYSICS= ',imp_physics - -! Initializes constants for Ferrier microphysics - if(imp_physics==5 .or. imp_physics==85 .or. imp_physics==95)then - CALL MICROINIT(imp_physics) - end if - - VarName='sf_surface_physi' - call nemsio_getheadvar(nfile,trim(VarName),iSF_SURFACE_PHYSICS,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned 2 for NOAH LSM as default" - iSF_SURFACE_PHYSICS=2 - end if - print*,'SF_SURFACE_PHYSICS= ',iSF_SURFACE_PHYSICS - -! IVEGSRC=1 for IGBP and 0 for USGS - VarName='IVEGSRC' - call nemsio_getheadvar(nfile,trim(VarName),IVEGSRC,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned 1 for IGBP as default" - IVEGSRC=1 - end if - print*,'IVEGSRC= ',IVEGSRC - -! set novegtype based on vegetation classification - if(ivegsrc==1)then - novegtype=20 - else if(ivegsrc==0)then - novegtype=24 - end if - print*,'novegtype= ',novegtype - - VarName='CU_PHYSICS' - call nemsio_getheadvar(nfile,trim(VarName),iCU_PHYSICS,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned 2 for BMJ as default" - iCU_PHYSICS=2 - end if - print*,'CU_PHYSICS= ',iCU_PHYSICS - - - allocate(bufy(jm)) - VarName='DX' -! if(me == 0)then -! call nemsio_getheadvar(nfile,trim(VarName),bufy,iret) -! if (iret /= 0) then -! print*,VarName," not found in file-Assigned missing values" -! dx=spval -! end if -! end if -! call mpi_bcast(bufy,jm,MPI_REAL,0,mpi_comm_comp,iret) -! do j=jsta,jend -! do i=1,im -! dx(i,j)=bufy(j) -! end do -! end do - if(debugprint)print*,'sample ',VarName,' = ',dx(im/2,(jsta+jend)/2) - - VarName='DY' -! if(me == 0)then -! call nemsio_getheadvar(nfile,trim(VarName),bufy,iret) -! if (iret /= 0) then -! print*,VarName," not found in file-Assigned missing values" -! dx=spval -! end if -! end if -! call mpi_bcast(bufy,jm,MPI_REAL,0,mpi_comm_comp,iret) -! do j=jsta,jend -! do i=1,im -! dy(i,j)=bufy(j) -! end do -! end do - if(debugprint)print*,'sample ',VarName,' = ',dy(im/2,(jsta+jend)/2) - deallocate(bufy) - - VarName='dt' - call nemsio_getheadvar(nfile,trim(VarName),garb,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned missing values" - dt=spval - else - dt=garb - end if - - VarName='dphd' - call nemsio_getheadvar(nfile,trim(VarName),garb,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned missing values" - dyval=spval - else - dyval=garb*gdsdegr - end if -! dyval=106 ! hard wire for AQ domain testing - - VarName='dlmd' - call nemsio_getheadvar(nfile,trim(VarName),garb,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned missing values" - dxval=spval - else - dxval=garb*gdsdegr - end if -! dxval=124 ! hard wire for AQ domain testing - - print*,'DX, DY, DT=',dxval,dyval,dt - - VarName='TPH0D' - call nemsio_getheadvar(nfile,trim(VarName),garb,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned missing values" - cenlat=spval - else - cenlat=nint(garb*gdsdegr) - end if - - VarName='TLM0D' - call nemsio_getheadvar(nfile,trim(VarName),garb,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned missing values" - cenlon=spval - else - if(grib=="grib2") then - cenlon=nint((garb+360.)*gdsdegr) - endif - end if - - varname='sg1' - call nemsio_getheadvar(nfile,trim(varname),eta1,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned missing values" - ETA1=SPVAL - end if - - varname='sg2' - call nemsio_getheadvar(nfile,trim(varname),eta2,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned missing values" - ETA2=SPVAL - end if - if(me==0)then - open(75,file='ETAPROFILE.txt',form='formatted', & - status='unknown') - DO L=1,lm+1 - write(75,1020)L, ETA1(lm+2-l), ETA2(lm+2-l) - END DO - 1020 format(I3,2E17.10) - close (75) - end if - - varname='pdtop' - call nemsio_getheadvar(nfile,trim(varname),pdtop,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned missing values" - pdtop=SPVAL - end if - - varname='pt' - call nemsio_getheadvar(nfile,trim(varname),pt,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned missing values" - pt=SPVAL - end if - print*,'PT, PDTOP= ',PT,PDTOP - - VarName='sldpth' - call nemsio_getheadvar(nfile,trim(varname),sldpth,iret) - print*,'SLDPTH= ',(SLDPTH(N),N=1,NSOIL) - -! set default to not empty buket - nprec=0 - nphs=0 - nclod=0 - nheat=0 - nrdlw=0 - nrdsw=0 - nsrfc=0 - - VarName='nprec' - call nemsio_getheadvar(nfile,trim(varname),nprec,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned zero" - end if - if(debugprint)print*,'sample ',VarName,' = ',nprec - - VarName='nphs' - call nemsio_getheadvar(nfile,trim(varname),nphs,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned zero" - end if - if(debugprint)print*,'sample ',VarName,' = ',nphs - - VarName='nclod' - call nemsio_getheadvar(nfile,trim(varname),nclod,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned zero" - end if - if(debugprint)print*,'sample ',VarName,' = ',nclod - - VarName='nheat' - call nemsio_getheadvar(nfile,trim(varname),nheat,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned zero" - end if - if(debugprint)print*,'sample ',VarName,' = ',nheat - - VarName='nrdlw' - call nemsio_getheadvar(nfile,trim(varname),nrdlw,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned zero" - end if - if(debugprint)print*,'sample ',VarName,' = ',nrdlw - - VarName='nrdsw' - call nemsio_getheadvar(nfile,trim(varname),nrdsw,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned zero" - end if - if(debugprint)print*,'sample ',VarName,' = ',nrdsw - - VarName='nsrfc' - call nemsio_getheadvar(nfile,trim(varname),nsrfc,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned zero" - end if - if(debugprint)print*,'sample ',VarName,' = ',nsrfc - - IF(.not. global)THEN - maptype=205 ! for Arakawa-B grid - gridtype='B' - ELSE - maptype=0 ! for global NMMB on latlon grid - gridtype='A' ! will put wind on mass point for now to make regular latlon - END IF - print*,'maptype and gridtype= ',maptype,gridtype - - HBM2=1.0 - -! start reading nemsio files using parallel read - fldsize=(jend-jsta+1)*im - allocate(tmp(fldsize*nrec)) - print*,'allocate tmp successfully' - tmp=0. - call nemsio_denseread(nfile,1,im,jsta,jend,tmp,iret=iret) - if(iret/=0)then - print*,"fail to read nemsio file using mpi io read, stopping" - stop - end if - - varname='glat' - VcoordName='sfc' - l=1 - call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & - ,l,nrec,fldsize,spval,tmp & - ,recname,reclevtyp,reclev,VarName,VcoordName & - ,gdlat) - - call collect_loc(gdlat,dummy) -! decides whether or not to convert to degree - if(me==0)then - if(maxval(abs(dummy))0. .and. gdlon(2,jsta)<0.)then - do j=jsta,jend - gdlon(1,j)=gdlon(1,j)-360.0 - end do - end if - end if - if(debugprint)print*,'sample ',VarName,' = ',(gdlon(i,(jsta+jend)/2),i=1,im,8) - if(debugprint)print*,'max min lon=',maxval(gdlon),minval(gdlon) - call collect_loc(gdlon,dummy) - if(me==0)then - if(grib=='grib2') then - if(dummy(1,1)<0) dummy(1,1)=dummy(1,1)+360. - if(dummy(im,jm)<0) dummy(im,jm)=dummy(im,jm)+360. - endif - lonstart=nint(dummy(1,1)*gdsdegr) - lonlast=nint(dummy(im,jm)*gdsdegr) - lonnw=nint(dummy(1,jm)*gdsdegr) - lonse=nint(dummy(im,1)*gdsdegr) -! dxval=nint((dummy(2,1)-dummy(1,1))*1000.) -! dxval=124 ! hard wire for AQ domain testing - if(mod(im,2)==0)then -! cenlon=nint((dummy(ii,jj)+dummy(ii+1,jj)+dummy(ii+1,jj+1)+dummy(ii,jj+1))/4.0*1000.) - else -! cenlon=nint(dummy(ii,jj)*1000.) - end if - end if - call mpi_bcast(lonstart,1,MPI_INTEGER,0,mpi_comm_comp,iret) - call mpi_bcast(lonlast,1,MPI_INTEGER,0,mpi_comm_comp,iret) -! call mpi_bcast(dxval,1,MPI_INTEGER,0,mpi_comm_comp,iret) -! call mpi_bcast(cenlon,1,MPI_INTEGER,0,mpi_comm_comp,iret) - write(6,*)'lonstart,lonlast A calling bcast=',lonstart,lonlast - print*,'dxval, cenlon= ',dxval, cenlon - - convert_rad_to_deg=.false. - varname='vlat' - VcoordName='sfc' - l=1 - call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & - ,l,nrec,fldsize,spval,tmp & - ,recname,reclevtyp,reclev,VarName,VcoordName & - ,buf) - - if(debugprint)print*,'sample ',VarName,' = ',buf(im/2,(jsta+jend)/2) - if(debugprint)print*,'max min vlat=',maxval(buf),minval(buf) - call collect_loc(buf,dummy) - if(me==0)then - if(maxval(abs(dummy)) 27.0 .or. sfcevp(i,j)<1.0)print*, & -! 'bad vegtype=',i,j,sfcevp(i,j) -! end do -! end do - - where(sfcevp /= spval)IVGTYP=nint(sfcevp) - if(debugprint)print*,'sample ',VarName,' = ',IVGTYP(im/2,(jsta+jend)/2) - - sfcevp=spval - VarName='sltyp' - VcoordName='sfc' - l=1 - call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & - ,l,nrec,fldsize,spval,tmp & - ,recname,reclevtyp,reclev,VarName,VcoordName & - ,sfcevp) ! temporary use sfcevp because it's real in nemsio - where(sfcevp /= spval)ISLTYP=nint(sfcevp) - if(debugprint)print*,'sample ',VarName,' = ',ISLTYP(im/2,(jsta+jend)/2) - - sfcevp=spval - VarName='sfcevp' - VcoordName='sfc' - l=1 - call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & - ,l,nrec,fldsize,spval,tmp & - ,recname,reclevtyp,reclev,VarName,VcoordName & - ,sfcevp) - if(debugprint)print*,'sample ',VarName,' = ',sfcevp(im/2,(jsta+jend)/2) - - VarName='sfcexc' - VcoordName='sfc' - l=1 - call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & - ,l,nrec,fldsize,spval,tmp & - ,recname,reclevtyp,reclev,VarName,VcoordName & - ,sfcexc) - if(debugprint)print*,'sample ',VarName,' = ',sfcexc(im/2,(jsta+jend)/2) - if(debugprint)print*,'MAX/MIN ',VarName,' = ' & - ,maxval(sfcexc),minval(sfcexc) - - VarName='acsnow' - VcoordName='sfc' - l=1 - call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & - ,l,nrec,fldsize,spval,tmp & - ,recname,reclevtyp,reclev,VarName,VcoordName & - ,acsnow) - if(debugprint)print*,'sample ',VarName,' = ',acsnow(im/2,(jsta+jend)/2) - - VarName='acsnom' - VcoordName='sfc' - l=1 - call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & - ,l,nrec,fldsize,spval,tmp & - ,recname,reclevtyp,reclev,VarName,VcoordName & - ,acsnom) - if(debugprint)print*,'sample ',VarName,' = ',acsnom(im/2,(jsta+jend)/2) - - VarName='tsea' - VcoordName='sfc' - l=1 - call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & - ,l,nrec,fldsize,spval,tmp & - ,recname,reclevtyp,reclev,VarName,VcoordName & - ,sst) - if(debugprint)print*,'sample ',VarName,' = ',sst(im/2,(jsta+jend)/2) - -! VarName='EL_PBL' ! not in nems io yet - VarName='xlen_mix' - VcoordName='mid layer' - do l=1,lm -! ll=lm-l+1 - ll=l - call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & - ,ll,nrec,fldsize,spval,tmp & - ,recname,reclevtyp,reclev,VarName,VcoordName & - ,EL_PBL(1,jsta_2l,ll)) - if(debugprint)print*,'sample l ',VarName,' = ',ll,EL_PBL(im/2,(jsta+jend)/2,ll) - end do ! do loop for l - - VarName='exch_h' - VcoordName='mid layer' - do l=1,lm -! ll=lm-l+1 - ll=l - call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & - ,ll,nrec,fldsize,spval,tmp & - ,recname,reclevtyp,reclev,VarName,VcoordName & - ,exch_h(1,jsta_2l,ll)) - if(debugprint)print*,'sample l ',VarName,' = ',ll,exch_h(im/2,(jsta+jend)/2,ll) - end do ! do loop for l - - VarName='thz0' - VcoordName='sfc' - l=1 - call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & - ,l,nrec,fldsize,spval,tmp & - ,recname,reclevtyp,reclev,VarName,VcoordName & - ,thz0) - if(debugprint)print*,'sample ',VarName,' = ',thz0(im/2,(jsta+jend)/2) - - VarName='qz0' - VcoordName='sfc' - l=1 - call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & - ,l,nrec,fldsize,spval,tmp & - ,recname,reclevtyp,reclev,VarName,VcoordName & - ,qz0) - if(debugprint)print*,'sample ',VarName,' = ',qz0(im/2,(jsta+jend)/2) - - VarName='uz0' - VcoordName='sfc' - l=1 - call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & - ,l,nrec,fldsize,spval,tmp & - ,recname,reclevtyp,reclev,VarName,VcoordName & - ,uz0) - if(debugprint)print*,'sample ',VarName,' = ',uz0(im/2,(jsta+jend)/2) - - VarName='vz0' - VcoordName='sfc' - l=1 - call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & - ,l,nrec,fldsize,spval,tmp & - ,recname,reclevtyp,reclev,VarName,VcoordName & - ,vz0) - if(debugprint)print*,'sample ',VarName,' = ',vz0(im/2,(jsta+jend)/2) - -! -! Very confusing story ... -! -! Retrieve htop and hbot => They are named CNVTOP, CNVBOT in the model and -! with HBOTS,HTOPS (shallow conv) and HBOTD,HTOPD (deep conv) represent -! the 3 sets of convective cloud base/top arrays tied to the frequency -! that history files are written. -! -! IN THE *MODEL*, arrays HBOT,HTOP are similar to CNVTOP,CNVBOT but are -! used in radiation and are tied to the frequency of radiation updates. -! -! For historical reasons model arrays CNVTOP,CNVBOT are renamed HBOT,HTOP -! and manipulated throughout the post. - -! retrieve htop and hbot -! VarName='HTOP' - VarName='cnvtop' - VcoordName='sfc' - l=1 - call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & - ,l,nrec,fldsize,spval,tmp & - ,recname,reclevtyp,reclev,VarName,VcoordName & - ,htop) - where(htop /= spval)htop=float(lm)-htop+1.0 -! where(htop /= spval .and. htop > lm)htop=lm*1.0 - if(debugprint)print*,'sample ',VarName,' = ',htop(im/2,(jsta+jend)/2) - -! VarName='HBOT' - VarName='cnvbot' - VcoordName='sfc' - l=1 - call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & - ,l,nrec,fldsize,spval,tmp & - ,recname,reclevtyp,reclev,VarName,VcoordName & - ,hbot) - where(hbot /= spval)hbot=float(lm)-hbot+1.0 -! where(hbot /= spval .and. hbot > lm)hbot=lm*1.0 - if(debugprint)print*,'sample ',VarName,' = ',hbot(im/2,(jsta+jend)/2) - - VarName='htopd' - VcoordName='sfc' - l=1 - call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & - ,l,nrec,fldsize,spval,tmp & - ,recname,reclevtyp,reclev,VarName,VcoordName & - ,htopd) - where(htopd /= spval)htopd=float(lm)-htopd+1.0 -! where(htopd /= spval .and. htopd > lm)htopd=lm*1.0 - if(debugprint)print*,'sample ',VarName,' = ',htopd(im/2,(jsta+jend)/2) - - VarName='hbotd' - VcoordName='sfc' - l=1 - call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & - ,l,nrec,fldsize,spval,tmp & - ,recname,reclevtyp,reclev,VarName,VcoordName & - ,hbotd) - where(hbotd /= spval)hbotd=float(lm)-hbotd+1.0 -! where(hbotd /= spval .and. hbotd > lm)hbotd=lm*1.0 - if(debugprint)print*,'sample ',VarName,' = ',hbotd(im/2,(jsta+jend)/2) - - VarName='htops' - VcoordName='sfc' - l=1 - call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & - ,l,nrec,fldsize,spval,tmp & - ,recname,reclevtyp,reclev,VarName,VcoordName & - ,htops) - where(htops /= spval)htops=float(lm)-htops+1.0 -! where(htops /= spval .and. htops > lm)htops=lm*1.0 - if(debugprint)print*,'sample ',VarName,' = ',htops(im/2,(jsta+jend)/2) - - VarName='hbots' - VcoordName='sfc' - l=1 - call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & - ,l,nrec,fldsize,spval,tmp & - ,recname,reclevtyp,reclev,VarName,VcoordName & - ,hbots) - where(hbots /= spval)hbots=float(lm)-hbots+1.0 -! where(hbots /= spval .and. hbots > lm)hbots=lm*1.0 - if(debugprint)print*,'sample ',VarName,' = ',hbots(im/2,(jsta+jend)/2) - - VarName='cuppt' - VcoordName='sfc' - l=1 - call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & - ,l,nrec,fldsize,spval,tmp & - ,recname,reclevtyp,reclev,VarName,VcoordName & - ,cuppt) - if(debugprint)print*,'sample ',VarName,' = ',cuppt(im/2,(jsta+jend)/2) - - VarName='cprate' - VcoordName='sfc' - l=1 - call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & - ,l,nrec,fldsize,spval,tmp & - ,recname,reclevtyp,reclev,VarName,VcoordName & - ,cprate) - if(debugprint)print*,'sample ',VarName,' = ',cprate(im/2,(jsta+jend)/2) - - deallocate(tmp,recname,reclevtyp,reclev) -!!!! DONE GETTING - - do l = 1, lm - do j = jsta, jend - do i = 1, im - IF(ABS(T(I,J,L))>1.0E-3) & - OMGA(I,J,L) = -WH(I,J,L)*PMID(I,J,L)*G/ & - (RD*T(I,J,L)*(1.+D608*Q(I,J,L))) - - end do - end do - end do - write(0,*)' after OMGA' - - - THL=210. - PLQ=70000. - - CALL TABLE(PTBL,TTBL,PT, & - RDQ,RDTH,RDP,RDTHE,PL,THL,QS0,SQS,STHE,THE0) - - CALL TABLEQ(TTBLQ,RDPQ,RDTHEQ,PLQ,THL,STHEQ,THE0Q) - write(0,*)' after TABLEQ' - - -! -! - IF(ME==0)THEN - WRITE(6,*)' SPL (POSTED PRESSURE LEVELS) BELOW: ' - WRITE(6,51) (SPL(L),L=1,LSM) - 50 FORMAT(14(F4.1,1X)) - 51 FORMAT(8(F8.1,1X)) - ENDIF -! -! COMPUTE DERIVED TIME STEPPING CONSTANTS. -! -!MEB need to get DT -! DT = 120. !MEB need to get DT -! NPHS = 4 !MEB need to get physics DT - DTQ2 = DT * NPHS !MEB need to get physics DT - TSPH = 3600./DT !MEB need to get DT - - IF (PTHRESH>0.) THEN - PTHRESH=0.01*DTQ2/3.6E6 !-- Precip rate >= 0.01 mm/h -! PTHRESH=0.01*DTQ2/(3600.*39.37) !-- Precip rate >= 0.01 inches/h - ENDIF - - TSRFC=float(NSRFC)/TSPH - IF(NSRFC==0)TSRFC=float(ifhr) !in case buket does not get emptied - TRDLW=float(NRDLW)/TSPH - IF(NRDLW==0)TRDLW=float(ifhr) !in case buket does not get emptied - TRDSW=float(NRDSW)/TSPH - IF(NRDSW==0)TRDSW=float(ifhr) !in case buket does not get emptied - THEAT=float(NHEAT)/TSPH - IF(NHEAT==0)THEAT=float(ifhr) !in case buket does not get emptied - TCLOD=float(NCLOD)/TSPH - IF(NCLOD==0)TCLOD=float(ifhr) !in case buket does not get emptied - TPREC=float(NPREC)/TSPH - IF(NPREC==0)TPREC=float(ifhr) !in case buket does not get emptied -! TPREC=float(ifhr) - print*,'TSRFC TRDLW TRDSW THEAT TCLOD TPREC= ' & - ,TSRFC, TRDLW, TRDSW, THEAT, TCLOD, TPREC -!MEB need to get DT - -!how am i going to get this information? -! 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) -!how am i going to get this information? -! -! IF(ME==0)THEN -! WRITE(6,*)' ' -! WRITE(6,*)'DERIVED TIME STEPPING CONSTANTS' -! WRITE(6,*)' NPREC,NHEAT,NSRFC : ',NPREC,NHEAT,NSRFC -! WRITE(6,*)' NCLOD,NRDSW,NRDLW : ',NCLOD,NRDSW,NRDLW -! ENDIF -! -! COMPUTE DERIVED MAP OUTPUT CONSTANTS. - DO L = 1,LSM - ALSL(L) = ALOG(SPL(L)) - END DO - write(0,*)' after ALSL' -! -!HC WRITE IGDS OUT FOR WEIGHTMAKER TO READ IN AS KGDSIN - if(me==0)then - print*,'writing out igds' - igdout=110 -! open(igdout,file='griddef.out',form='unformatted' -! + ,status='unknown') - IF(MAPTYPE==203)THEN !A STAGGERED E-GRID - WRITE(igdout)203 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)136 - WRITE(igdout)CENLAT - WRITE(igdout)CENLON - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)64 - WRITE(igdout)0 - WRITE(igdout)0 - WRITE(igdout)0 - WRITE(igdout)LATLAST - WRITE(igdout)LONLAST - ELSE IF(MAPTYPE==205)THEN !A STAGGERED B-GRID - WRITE(igdout)205 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)136 - WRITE(igdout)CENLAT - WRITE(igdout)CENLON - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)64 - WRITE(igdout)LATLAST - WRITE(igdout)LONLAST - WRITE(igdout)0 - WRITE(igdout)0 - WRITE(igdout)0 - END IF - open(111,file='copygb_gridnav.txt',form='formatted' & - ,status='unknown') - IF(MAPTYPE==203)THEN !A STAGGERED E-GRID - write(111,1000) 2*IM-1,JM,LATSTART,LONSTART,CENLON, & - NINT(dxval*107.),NINT(dyval*110.),CENLAT,CENLAT - ELSE IF(MAPTYPE==205)THEN !A STAGGERED B-GRID - if(grib=="grib2") then - write(111,1000) IM,JM,LATSTART/1000,LONSTART/1000,CENLON/1000, & - NINT(dxval*107.)/1000,NINT(dyval*110.)/1000, & - CENLAT/1000,CENLAT/1000, & - LATLAST/1000,LONLAST/1000 - endif - END IF -1000 format('255 3 ',2(I4,x),I6,x,I7,x,'8 ',I7,x,2(I6,x),'0 64', & - 3(x,I6),x,I7) - close(111) -! - IF (MAPTYPE==205)THEN !A STAGGERED B-GRID - open(112,file='latlons_corners.txt',form='formatted' & - ,status='unknown') - if(grib=="grib2") then - write(112,1001)LATSTART/1000,(LONSTART/1000)-360000, & - LATSE/1000, & - LONSE/1000,LATNW/1000,LONNW/1000,LATLAST/1000, & - (LONLAST/1000)-360000 - endif -1001 format(4(I6,x,I7,x)) - close(112) - ENDIF - - end if - -! close all files - call nemsio_close(nfile,iret=status) - call nemsio_finalize() -! - write(0,*)'end of INIT_NEMS' - - RETURN - END From 262d0f30e29210492b2433c7219d505c1ba1059c Mon Sep 17 00:00:00 2001 From: Wen Meng Date: Sat, 15 Jan 2022 01:04:46 +0000 Subject: [PATCH 5/8] Fix build failture. --- sorc/ncep_post.fd/INITPOST_NEMS.f | 2851 +++++++++++++++++++++++++++++ sorc/ncep_post.fd/INITPOST_NMM.f | 2643 -------------------------- 2 files changed, 2851 insertions(+), 2643 deletions(-) create mode 100644 sorc/ncep_post.fd/INITPOST_NEMS.f delete mode 100644 sorc/ncep_post.fd/INITPOST_NMM.f diff --git a/sorc/ncep_post.fd/INITPOST_NEMS.f b/sorc/ncep_post.fd/INITPOST_NEMS.f new file mode 100644 index 000000000..39459701f --- /dev/null +++ b/sorc/ncep_post.fd/INITPOST_NEMS.f @@ -0,0 +1,2851 @@ +!> @file +! . . . +!> SUBPROGRAM: INITPOST INITIALIZE POST FOR RUN +!! PRGRMMR: Hui-Ya Chuang DATE: 2008-03-26 +!! +!! ABSTRACT: THIS ROUTINE INITIALIZES CONSTANTS AND +!! VARIABLES AT THE START OF AN NEMS MODEL OR POST +!! PROCESSOR RUN. +!! +!! REVISION HISTORY +!! 21-03-11 Bo Cui - change local arrays to dimension (im,jsta:jend) +!! +!! USAGE: CALL INITPOST_NEMS +!! INPUT ARGUMENT LIST: +!! NREC +!! NFILE +!! +!! OUTPUT ARGUMENT LIST: +!! NONE +!! +!! OUTPUT FILES: +!! NONE +!! +!! SUBPROGRAMS CALLED: +!! UTILITIES: +!! NONE +!! LIBRARY: +!! COMMON - CTLBLK +!! LOOKUP +!! SOILDEPTH +!! +!! +!! ATTRIBUTES: +!! LANGUAGE: FORTRAN +!! MACHINE : CRAY C-90 +!! + SUBROUTINE INITPOST_NEMS(NREC,nfile) + + use vrbls3d, only: t, q, uh, vh, q2, cwm, f_ice, f_rain, f_rimef, cfr, pint,& + pint, alpint, pmid, pmidv, zint, zmid, wh, rlwtt, rswtt,& + ttnd, tcucn, train, el_pbl, exch_h, omga, qqni, qqnr, qqw, qqi, & + qqr, qqs, qqg, REF_10CM, radius_cloud, radius_ice, radius_snow, & + extcof55, aextc55 + use vrbls2d, only: f, pd, fis, pblh, mixht, ustar, z0, ths, qs, twbs, qwbs, prec,& + acprec, cuprec,ancprc, lspa, sno, snoavg, psfcavg, t10avg, t10m, akhsavg, akmsavg,& + refd_max, w_up_max, w_dn_max, up_heli_max, si, cldefi, th10, q10, pshltr,& + tshltr, qshltr, maxtshltr, mintshltr, maxrhshltr, minrhshltr, akhs, akms, albase,& + albedo, czen, cfracl, cfracm, islope, cmc, grnflx, pctsno, soiltb, vegfrc,& + acfrcv, acfrst, ssroff, bgroff, czmean, mxsnal, radot, sigt4, tg, sr, cfrach,& + rlwin, rlwtoa, alwin, alwout, alwtoa, rswin, rswinc, rswout, aswin,aswout,& + aswtoa, sfcshx, sfclhx, subshx, snopcx, sfcuvx, potevp, ncfrcv, ncfrst, u10h,& + u10, v10h, v10, u10max, v10max, smstav, smstot, sfcevp, ivgtyp, acsnow, acsnom,& + sst, thz0, qz0, uz0, vz0, htop, isltyp, sfcexc, hbot, htopd, htops, cuppt, cprate,& + hbotd, hbots, prate_max, fprate_max + use soil, only: sldpth, sh2o, smc, stc + use masks, only: lmv, lmh, htm, vtm, dx, dy, hbm2, gdlat, gdlon, sm, sice + use kinds, only: i_llong + use wrf_io_flags_mod, only: + use params_mod, only: pi, dtr, g, d608, rd,tfrz + use lookup_mod, only: thl, plq, ptbl, ttbl, rdq, rdth, rdp, rdthe, pl, qs0, sqs, sthe, the0,& + ttblq, rdpq, rdtheq, stheq, the0q + use ctlblk_mod, only: me, mpi_comm_comp, global, icnt, idsp, jsta, ihrst, imin, idat, sdat,& + ifhr, ifmin, filename, restrt, imp_physics, isf_surface_physics, icu_physics, jend,& + dt, spval, gdsdegr, grib, pdtop, pt, tmaxmin, nsoil, lp1, jend_m, nprec, nphs, avrain,& + avcnvc, ardlw, ardsw, asrfc, novegtype, spl, lsm, dtq2, tsrfc, trdlw, trdsw, theat, tclod,& + tprec, alsl, lm , im, jm, jsta_2l, jend_2u, ivegsrc, pthresh + use gridspec_mod, only: dyval, dxval, cenlat, cenlon, maptype, gridtype, latstart, latlast, latnw,& + latse, lonstart, lonlast, lonnw, lonse, latstartv, latlastv, cenlatv, lonstartv,& + lonlastv, cenlonv + use nemsio_module, only: nemsio_gfile, nemsio_getfilehead, nemsio_close, nemsio_getheadvar + use upp_math, only: h2u +! +! INCLUDE/SET PARAMETERS. + implicit none +! + type(nemsio_gfile),intent(inout) :: nfile +! + INCLUDE "mpif.h" +! This version of INITPOST shows how to initialize, open, read from, and +! close a NetCDF dataset. In order to change it to read an internal (binary) +! dataset, do a global replacement of _ncd_ with _int_. + + character(len=20) :: VarName + character(len=20) :: VcoordName + integer :: Status + character startdate*19,SysDepInfo*80,cgar*1 + character startdate2(19)*4 +! +! NOTE: SOME INTEGER VARIABLES ARE READ INTO DUMMY ( A REAL ). THIS IS OK +! AS LONG AS REALS AND INTEGERS ARE THE SAME SIZE. +! +! ALSO, EXTRACT IS CALLED WITH DUMMY ( A REAL ) EVEN WHEN THE NUMBERS ARE +! INTEGERS - THIS IS OK AS LONG AS INTEGERS AND REALS ARE THE SAME SIZE. + logical, parameter :: debugprint = .false. +! logical, parameter :: debugprint = .true. + logical :: convert_rad_to_deg=.false. +! logical global +! CHARACTER BLANK*4 + integer nfhour ! forecast hour from nems io file + INTEGER IDATE(8),JDATE(8) +! +! DECLARE VARIABLES. +! + REAL FACT,tsph,tstart + REAL RINC(5) + REAL ETA1(LM+1), ETA2(LM+1) + REAL GARB + REAL DUM1D (LM+1) + REAL DUMMY ( IM, JM ) + REAL DUMMY2 ( IM, JM ) + real, allocatable :: fi(:,:,:) + + integer ibuf(im,jsta_2l:jend_2u) + real buf(im,jsta_2l:jend_2u) + character*8,allocatable:: recname(:) + character*16,allocatable :: reclevtyp(:) + integer,allocatable:: reclev(:) + real, allocatable:: bufy(:) + real, allocatable:: glat1d(:),glon1d(:) +!jw + integer ii,jj,js,je,jev,iyear,imn,iday,itmp,ioutcount,istatus, & + nsrfc,nrdlw,nrdsw,nheat,nclod, & + iunit,nrec,I,J,L, iret,nframe,impf,jmpf,nframed2, & + igdout,ll,n,im1,jm1,iim1,item +! +! DATA BLANK/' '/ +! +!*********************************************************************** +! START INIT HERE. +! + if(me==0)WRITE(6,*)'INITPOST: ENTER INITPOST' +! +! +! STEP 1. READ MODEL OUTPUT FILE +! +!*** +! LMH always = LM for sigma-type vert coord +! LMV always = LM for sigma-type vert coord + + do j = jsta_2l, jend_2u + do i = 1, im + LMV ( i, j ) = lm + LMH ( i, j ) = lm + end do + end do + +! HTM VTM all 1 for sigma-type vert coord + + do l = 1, lm + do j = jsta_2l, jend_2u + do i = 1, im + HTM ( i, j, l ) = 1.0 + VTM ( i, j, l ) = 1.0 + end do + end do + end do + +! The end j row is going to be jend_2u for all variables except for V. + JS=JSTA_2L + JE=JEND_2U + IF (JEND_2U==JM) THEN + JEV=JEND_2U+1 + ELSE + JEV=JEND_2U + ENDIF +! sample print point + ii=(1+im)/2 + jj=(1+jm)/2 +! get start date + idate=0 + if (me == 0)then + print*,'nrec=',nrec + allocate(recname(nrec),reclevtyp(nrec),reclev(nrec)) + + call nemsio_getfilehead(nfile,iret=iret & + ,idate=idate(1:7),nfhour=nfhour,recname=recname & + ,reclevtyp=reclevtyp,reclev=reclev,nframe=nframe) +! if(iret/=0)print*,'error getting idate,fhour, stopping';stop + if (debugprint) then + print *,'printing an inventory of NEMS file' + do i=1,nrec + print *,'recname,reclevtyp,reclev=',trim(recname(i)),' ', & + trim(reclevtyp(i)),reclev(i) + end do + endif +! print *,'reclevtyp=',(trim(reclevtyp(i)),i=1,nrec) +! print *,'reclev=',(reclev(i),i=1,nrec) + deallocate(recname,reclevtyp,reclev) + impf=im+nframe*2 + jmpf=jm+nframe*2 +! nframed2=nframe/2 + print*,'nframe,impf,jmpf= ',nframe,impf,jmpf + allocate(glat1d(impf*jmpf),glon1d(impf*jmpf) ) + call nemsio_getfilehead(nfile,dx=glat1d & + ,dy=glon1d,iret=iret) + if(iret/=0)print*,'did not find dx dy' +! do j=1,impf*jmpf +! print*,'dx before scatter= ',j,glat1d(j) +! end do +!$omp parallel do private(i,j,item) + do j=1,jm + item = (j-1)*impf + nframe + do i=1,im + dummy(i,j) = glat1d(item+i) + dummy2(i,j) = glon1d(item+i) +! dummy(i,j)=glat1d(i-nframe,j-nframe) +! dummy2(i,j)=glon1d(i-nframe,j-nframe) + end do + end do + deallocate(glat1d,glon1d) +! latstart=nint(dummy(1,1)*1000.) +! latlast=nint(dummy(im,jm)*1000.) +! lonstart=nint(dummy2(1,1)*1000.) +! lonlast=nint(dummy2(im,jm)*1000.) +! dyval=nint((dummy(1,2)-dummy(1,1))*1000.) +! dxval=nint((dummy(2,1)-dummy(1,1))*1000.) +! cenlat=nint(dummy(ii,jj)*1000.) +! cenlon=nint(dummy2(ii,jj)*1000.) + print*,'idate before broadcast = ',(idate(i),i=1,7) + end if + call mpi_bcast(idate(1),7,MPI_INTEGER,0,mpi_comm_comp,iret) + call mpi_bcast(nfhour,1,MPI_INTEGER,0,mpi_comm_comp,iret) + call mpi_bcast(nframe,1,MPI_INTEGER,0,mpi_comm_comp,iret) +! call mpi_bcast(latstart,1,MPI_INTEGER,0,mpi_comm_comp,iret) +! call mpi_bcast(latlast,1,MPI_INTEGER,0,mpi_comm_comp,iret) +! call mpi_bcast(lonstart,1,MPI_INTEGER,0,mpi_comm_comp,iret) +! call mpi_bcast(lonlast,1,MPI_INTEGER,0,mpi_comm_comp,iret) +! call mpi_bcast(cenlat,1,MPI_INTEGER,0,mpi_comm_comp,iret) +! call mpi_bcast(cenlon,1,MPI_INTEGER,0,mpi_comm_comp,iret) +! print*, 'latstart,latlast A calling bcast=',latstart,latlast +! print*,'lonstart,lonlast A calling bcast=',lonstart,lonlast +! print*,'cenlat,cenlon A calling bcast=',cenlat,cenlon + +! if(me == 0)then +! call nemsio_getheadvar(nfile,'global',global,iret) +! if (iret /= 0) then +! print*,"global not found in file-Assigned false" +! global=.FALSE. +! end if +! end if +! call mpi_bcast(global,1,MPI_LOGICAL,0,mpi_comm_comp,iret) + +! print*,'Is this a global run ',global + IF(.not. global)THEN +! nframe=0 ! Wang added option to read without halos, so specify nframe=0 + impf=im+nframe*2 + jmpf=jm+nframe*2 +! nframed2=nframe/2 + ELSE +! nframe=1 ! + impf=im+1 ! post cut im off because it's the same as i=1 but data from model is till im + jmpf=jm +! nframed2=nframe/2 + END IF + + if (debugprint) then + print*,'impf,jmpf,nframe for reading fields = ',impf,jmpf,nframe + print*,'idate after broadcast = ',(idate(i),i=1,7) + print*,'nfhour = ',nfhour + end if + call mpi_scatterv(dummy(1,1),icnt,idsp,mpi_real & + ,dx(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,iret) + call mpi_scatterv(dummy2(1,1),icnt,idsp,mpi_real & + ,dy(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,iret) + +! print *,'before call EXCH,mype=',me,'max(gdlat)=',maxval(gdlat),'max(gdlon)=', & +! maxval(gdlon) +! CALL EXCH(gdlat(1,JSTA_2L)) +! print *,'after call EXCH,mype=',me + + iyear = idate(1) + imn = idate(2) ! ask Jun + iday = idate(3) ! ask Jun + ihrst = idate(4) + imin = idate(5) + jdate = 0 + idate = 0 +! +! read(startdate,15)iyear,imn,iday,ihrst,imin + 15 format(i4,1x,i2,1x,i2,1x,i2,1x,i2) + if (me==0) then + print*,'start yr mo day hr min =',iyear,imn,iday,ihrst,imin + print*,'processing yr mo day hr min=' & + ,idat(3),idat(1),idat(2),idat(4),idat(5) + endif +! + idate(1) = iyear + idate(2) = imn + idate(3) = iday + idate(5) = ihrst + idate(6) = imin + SDAT(1) = imn + SDAT(2) = iday + SDAT(3) = iyear + jdate(1) = idat(3) + jdate(2) = idat(1) + jdate(3) = idat(2) + jdate(5) = idat(4) + jdate(6) = idat(5) +! + +! CALL W3DIFDAT(JDATE,IDATE,2,RINC) +! ifhr=nint(rinc(2)) +! + CALL W3DIFDAT(JDATE,IDATE,0,RINC) +! + ifhr=nint(rinc(2)+rinc(1)*24.) + ifmin=nint(rinc(3)) +! if(ifhr /= nfhour)print*,'find wrong Model input file';stop + if (me==0)print*,' in INITPOST ifhr ifmin fileName=',ifhr,ifmin,trim(fileName) + +! Getting tstart + tstart=0. + +! Getiing restart + + RESTRT=.TRUE. ! set RESTRT as default +! call ext_int_get_dom_ti_integer(DataHandle,'RESTARTBIN',itmp +! + ,1,ioutcount,istatus) + +! IF(itmp < 1)THEN +! RESTRT=.FALSE. +! ELSE +! RESTRT=.TRUE. +! END IF + +! print*,'status for getting RESTARTBIN= ',istatus + +! print*,'Is this a restrt run? ',RESTRT + + IF(tstart > 1.0E-2)THEN + ifhr=ifhr+NINT(tstart) + rinc=0 + idate=0 + rinc(2)=-1.0*ifhr + call w3movdat(rinc,jdate,idate) + SDAT(1)=idate(2) + SDAT(2)=idate(3) + SDAT(3)=idate(1) + IHRST=idate(5) + print*,'new forecast hours for restrt run= ',ifhr + print*,'new start yr mo day hr min =',sdat(3),sdat(1) & + ,sdat(2),ihrst,imin + END IF + + +!KRF: Initialize extinction coef for aerosol to zero to avoid failure. +! These are not in NEMS model output, but new CALVIS_GSD methods uses +! these fields from ARW, and if not initialized here will cause failure. + extcof55=0. + aextc55=0. + +!Chuang: set default to Ferrier's MP scheme. NPS does not write MP option +!used in model to nemsio output + VarName='mp_physi' + if(me == 0)then + call nemsio_getheadvar(nfile,trim(VarName),imp_physics,iret) + if (iret /= 0) then + print*,VarName," not found in file- go to 16 character " + VarName='mp_physics' + call nemsio_getheadvar(nfile,trim(VarName),imp_physics,iret) + if (iret /= 0) then + print*,VarName," not found in file-Assigned 1000" +! imp_physics=1000 ! should this line be uncommented? - Moorthi + imp_physics=5 + end if + end if + end if + call mpi_bcast(imp_physics,1,MPI_INTEGER,0,mpi_comm_comp,iret) + if(me==0)print*,'MP_PHYSICS= ',imp_physics + +! Initializes constants for Ferrier microphysics + if(imp_physics==5 .or. imp_physics==85 .or. imp_physics==95)then + CALL MICROINIT(imp_physics) + end if + + VarName='sf_surface_physi' + if(me == 0)then + call nemsio_getheadvar(nfile,trim(VarName),iSF_SURFACE_PHYSICS,iret) + if (iret /= 0) then + print*,VarName," not found in file-Assigned 2 for NOAH LSM as default" + iSF_SURFACE_PHYSICS=2 + end if + end if + call mpi_bcast(iSF_SURFACE_PHYSICS,1,MPI_INTEGER,0,mpi_comm_comp,iret) + if(me==0) print*,'SF_SURFACE_PHYSICS= ',iSF_SURFACE_PHYSICS + +! IVEGSRC=1 for IGBP and 0 for USGS + VarName='IVEGSRC' + if(me == 0)then + call nemsio_getheadvar(nfile,trim(VarName),IVEGSRC,iret) + if (iret /= 0) then + print*,VarName," not found in file-Assigned 1 for IGBP as default" + IVEGSRC=1 + end if + end if + call mpi_bcast(IVEGSRC,1,MPI_INTEGER,0,mpi_comm_comp,iret) + if(me==0) print*,'IVEGSRC= ',IVEGSRC + +! set novegtype based on vegetation classification + if(ivegsrc==1)then + novegtype=20 + else if(ivegsrc==0)then + novegtype=24 + end if + if(me==0) print*,'novegtype= ',novegtype + + VarName='CU_PHYSICS' + if(me == 0)then + call nemsio_getheadvar(nfile,trim(VarName),iCU_PHYSICS,iret) + if (iret /= 0) then + print*,VarName," not found in file-Assigned 2 for BMJ as default" + iCU_PHYSICS=2 + end if + end if + call mpi_bcast(iCU_PHYSICS,1,MPI_INTEGER,0,mpi_comm_comp,iret) + if(me==0) print*,'CU_PHYSICS= ',iCU_PHYSICS + + + allocate(bufy(jm)) + VarName='DX' +! if(me == 0)then +! call nemsio_getheadvar(nfile,trim(VarName),bufy,iret) +! if (iret /= 0) then +! print*,VarName," not found in file-Assigned missing values" +! dx=spval +! end if +! end if +! call mpi_bcast(bufy,jm,MPI_REAL,0,mpi_comm_comp,iret) +! do j=jsta,jend +! do i=1,im +! dx(i,j)=bufy(j) +! end do +! end do + if(debugprint)print*,'sample ',VarName,' = ',dx(im/2,(jsta+jend)/2) + + VarName='DY' +! if(me == 0)then +! call nemsio_getheadvar(nfile,trim(VarName),bufy,iret) +! if (iret /= 0) then +! print*,VarName," not found in file-Assigned missing values" +! dx=spval +! end if +! end if +! call mpi_bcast(bufy,jm,MPI_REAL,0,mpi_comm_comp,iret) +! do j=jsta,jend +! do i=1,im +! dy(i,j)=bufy(j) +! end do +! end do + if(debugprint)print*,'sample ',VarName,' = ',dy(im/2,(jsta+jend)/2) + deallocate(bufy) + + VarName='dt' + if(me == 0)then + call nemsio_getheadvar(nfile,trim(VarName),garb,iret) + if (iret /= 0) then + print*,VarName," not found in file-Assigned missing values" + dt=spval + else + dt=garb + end if + end if + call mpi_bcast(dt,1,MPI_REAL,0,mpi_comm_comp,iret) + + VarName='dphd' + if(me == 0)then + call nemsio_getheadvar(nfile,trim(VarName),garb,iret) + if (iret /= 0) then + print*,VarName," not found in file-Assigned missing values" + dyval=spval + else + dyval=garb*gdsdegr + end if + end if + call mpi_bcast(dyval,1,MPI_REAL,0,mpi_comm_comp,iret) +! dyval=106 ! hard wire for AQ domain testing + + VarName='dlmd' + if(me == 0)then + call nemsio_getheadvar(nfile,trim(VarName),garb,iret) + if (iret /= 0) then + print*,VarName," not found in file-Assigned missing values" + dxval=spval + else + dxval=garb*gdsdegr + end if + end if + call mpi_bcast(dxval,1,MPI_REAL,0,mpi_comm_comp,iret) +! dxval=124 ! hard wire for AQ domain testing + + if(me==0) print*,'DX, DY, DT=',dxval,dyval,dt + + VarName='TPH0D' + if(me == 0)then + call nemsio_getheadvar(nfile,trim(VarName),garb,iret) + if (iret /= 0) then + print*,VarName," not found in file-Assigned missing values" + cenlat=spval + else + cenlat=nint(garb*gdsdegr) + end if + end if + call mpi_bcast(cenlat,1,MPI_INTEGER,0,mpi_comm_comp,iret) + + VarName='TLM0D' + if(me == 0)then + call nemsio_getheadvar(nfile,trim(VarName),garb,iret) + if (iret /= 0) then + print*,VarName," not found in file-Assigned missing values" + cenlon=spval + else + if(grib=="grib2") then + cenlon=nint((garb+360.)*gdsdegr) + endif + end if + end if + call mpi_bcast(cenlon,1,MPI_INTEGER,0,mpi_comm_comp,iret) + +! VarName='TRUELAT1' +! call retrieve_index(index,VarName,varname_all,nrecs,iret) +! if (iret /= 0) then +! print*,VarName," not found in file" +! else +! call mpi_file_read_at(iunit,file_offset(index)+5*4 & +! ,garb,1,mpi_real4, mpi_status_ignore, ierr) +! if (ierr /= 0) then +! print*,"Error reading ", VarName," using MPIIO" +! else +! print*,VarName, ' from MPIIO READ= ',garb +! TRUELAT1=nint(garb*1000.) +! write(6,*) 'truelat1= ', TRUELAT1 +! end if +! end if + +! VarName='TRUELAT2' +! call retrieve_index(index,VarName,varname_all,nrecs,iret) +! if (iret /= 0) then +! print*,VarName," not found in file" +! else +! call mpi_file_read_at(iunit,file_offset(index)+5*4 & +! ,garb,1,mpi_real4, mpi_status_ignore, ierr) +! if (ierr /= 0) then +! print*,"Error reading ", VarName," using MPIIO" +! else +! print*,VarName, ' from MPIIO READ= ',garb +! TRUELAT2=nint(garb*1000.) +! write(6,*) 'truelat2= ', TRUELAT2 +! end if +! end if + +! VarName='MAP_PROJ' +! if(me == 0)then +! call nemsio_getheadvar(nfile,trim(VarName),maptype,iret) +! if (iret /= 0) then +! print*,VarName," not found in file-Assigned 1000" +! maptype=1000 +! end if +! end if +! call mpi_bcast(maptype,1,MPI_INTEGER,0,mpi_comm_comp,iret) + IF(.not. global)THEN + maptype=205 ! for Arakawa-B grid + gridtype='B' + ELSE + maptype=0 ! for global NMMB on latlon grid + gridtype='A' ! will put wind on mass point for now to make regular latlon + END IF + if(me==0) print*,'maptype and gridtype= ',maptype,gridtype + + HBM2=1.0 + + varname='glat' + VcoordName='sfc' + l=1 + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,impf,jmpf,nframe,gdlat) + + call collect_loc(gdlat,dummy) +! decides whether or not to convert to degree + if(me==0)then + if(maxval(abs(dummy))0. .and. gdlon(2,jsta)<0.)then + do j=jsta,jend + gdlon(1,j) = gdlon(1,j)-360.0 + end do + end if + end if + if(debugprint)print*,'sample ',VarName,' = ',(gdlon(i,(jsta+jend)/2),i=1,im,8) + if(debugprint)print*,'max min lon=',maxval(gdlon),minval(gdlon) + call collect_loc(gdlon,dummy) + if(me==0)then + if(grib=='grib2') then + if(dummy(1,1)<0) dummy(1,1)=dummy(1,1)+360. + if(dummy(im,jm)<0) dummy(im,jm)=dummy(im,jm)+360. + endif + lonstart=nint(dummy(1,1)*gdsdegr) + lonlast=nint(dummy(im,jm)*gdsdegr) + lonnw=nint(dummy(1,jm)*gdsdegr) + lonse=nint(dummy(im,1)*gdsdegr) +! dxval=nint((dummy(2,1)-dummy(1,1))*1000.) +! dxval=124 ! hard wire for AQ domain testing + if(mod(im,2)==0)then +! cenlon=nint((dummy(ii,jj)+dummy(ii+1,jj)+dummy(ii+1,jj+1)+dummy(ii,jj+1))/4.0*1000.) + else +! cenlon=nint(dummy(ii,jj)*1000.) + end if + end if + call mpi_bcast(lonstart,1,MPI_INTEGER,0,mpi_comm_comp,iret) + call mpi_bcast(lonlast,1,MPI_INTEGER,0,mpi_comm_comp,iret) +! call mpi_bcast(dxval,1,MPI_INTEGER,0,mpi_comm_comp,iret) +! call mpi_bcast(cenlon,1,MPI_INTEGER,0,mpi_comm_comp,iret) + write(6,*)'lonstart,lonlast A calling bcast=',lonstart,lonlast + print*,'dxval, cenlon= ',dxval, cenlon + + convert_rad_to_deg=.false. + varname='vlat' + VcoordName='sfc' + l=1 + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,impf,jmpf,nframe,buf) + if(debugprint)print*,'sample ',VarName,' = ',buf(im/2,(jsta+jend)/2) + if(debugprint)print*,'max min vlat=',maxval(buf),minval(buf) + call collect_loc(buf,dummy) + if(me==0)then + if(maxval(abs(dummy)) 27.0 .or. sfcevp(i,j)<1.0)print*, & +! 'bad vegtype=',i,j,sfcevp(i,j) +! end do +! end do + + where(sfcevp /= spval)IVGTYP=nint(sfcevp) + if(debugprint)print*,'sample ',VarName,' = ',IVGTYP(im/2,(jsta+jend)/2) + + VarName='SLTYP' + VcoordName='sfc' + l=1 + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,impf,jmpf,nframe,sfcevp) + where(sfcevp /= spval)ISLTYP=nint(sfcevp) + if(debugprint)print*,'sample ',VarName,' = ',ISLTYP(im/2,(jsta+jend)/2) + +! call retrieve_index(index,VarName,varname_all,nrecs,iret) +! if (iret /= 0) then +! print*,VarName," not found in file-Assigned missing values" +! ISLTYP=NINT(SPVAL) +! else +! this_offset=file_offset(index+1)+(jsta_2l-1)*4*im +! this_length=im*(jend_2u-jsta_2l+1) +! call mpi_file_read_at(iunit,this_offset & +! ,isltyp,this_length,mpi_integer4, mpi_status_ignore, ierr) +! if (ierr /= 0) then +! print*,"Error reading ", VarName,"Assigned missing values" +! ISLTYP=NINT(SPVAL) +! end if +! end if + + VarName='sfcevp' + VcoordName='sfc' + l=1 + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,impf,jmpf,nframe,sfcevp) + if(debugprint)print*,'sample ',VarName,' = ',sfcevp(im/2,(jsta+jend)/2) + + VarName='sfcexc' + VcoordName='sfc' + l=1 + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,impf,jmpf,nframe,sfcexc) + if(debugprint)print*,'sample ',VarName,' = ',sfcexc(im/2,(jsta+jend)/2) + if(debugprint)print*,'MAX/MIN ',VarName,' = ' & + ,maxval(sfcexc),minval(sfcexc) + + VarName='acsnow' + VcoordName='sfc' + l=1 + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,impf,jmpf,nframe,acsnow) + if(debugprint)print*,'sample ',VarName,' = ',acsnow(im/2,(jsta+jend)/2) + + VarName='acsnom' + VcoordName='sfc' + l=1 + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,impf,jmpf,nframe,acsnom) + if(debugprint)print*,'sample ',VarName,' = ',acsnom(im/2,(jsta+jend)/2) + + VarName='tsea' + VcoordName='sfc' + l=1 + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,impf,jmpf,nframe,sst) + if(debugprint)print*,'sample ',VarName,' = ',sst(im/2,(jsta+jend)/2) + +! VarName='EL_PBL' ! not in nems io yet + VarName='xlen_mix' + VcoordName='mid layer' + do l=1,lm +! ll=lm-l+1 + ll=l + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,impf,jmpf,nframe,EL_PBL(1,jsta_2l,ll)) + if(debugprint)print*,'sample l ',VarName,' = ',ll,EL_PBL(im/2,(jsta+jend)/2,ll) + end do ! do loop for l + + VarName='exch_h' + VcoordName='mid layer' + do l=1,lm +! ll=lm-l+1 + ll=l + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,impf,jmpf,nframe,exch_h(1,jsta_2l,ll)) + if(debugprint)print*,'sample l ',VarName,' = ',ll,exch_h(im/2,(jsta+jend)/2,ll) + end do ! do loop for l + + VarName='thz0' + VcoordName='sfc' + l=1 + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,impf,jmpf,nframe,thz0) + if(debugprint)print*,'sample ',VarName,' = ',thz0(im/2,(jsta+jend)/2) + + VarName='qz0' + VcoordName='sfc' + l=1 + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,impf,jmpf,nframe,qz0) + if(debugprint)print*,'sample ',VarName,' = ',qz0(im/2,(jsta+jend)/2) + + VarName='uz0' + VcoordName='sfc' + l=1 + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,impf,jmpf,nframe,uz0) + if(debugprint)print*,'sample ',VarName,' = ',uz0(im/2,(jsta+jend)/2) + + VarName='vz0' + VcoordName='sfc' + l=1 + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,impf,jmpf,nframe,vz0) + if(debugprint)print*,'sample ',VarName,' = ',vz0(im/2,(jsta+jend)/2) + +! +! Very confusing story ... +! +! Retrieve htop and hbot => They are named CNVTOP, CNVBOT in the model and +! with HBOTS,HTOPS (shallow conv) and HBOTD,HTOPD (deep conv) represent +! the 3 sets of convective cloud base/top arrays tied to the frequency +! that history files are written. +! +! IN THE *MODEL*, arrays HBOT,HTOP are similar to CNVTOP,CNVBOT but are +! used in radiation and are tied to the frequency of radiation updates. +! +! For historical reasons model arrays CNVTOP,CNVBOT are renamed HBOT,HTOP +! and manipulated throughout the post. + +! retrieve htop and hbot +! VarName='HTOP' + VarName='cnvtop' + VcoordName='sfc' + l=1 + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,impf,jmpf,nframe,htop) + where(htop /= spval)htop=float(lm)-htop+1.0 +! where(htop /= spval .and. htop > lm)htop=lm*1.0 + if(debugprint)print*,'sample ',VarName,' = ',htop(im/2,(jsta+jend)/2) + +! VarName='HBOT' + VarName='cnvbot' + VcoordName='sfc' + l=1 + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,impf,jmpf,nframe,hbot) + where(hbot /= spval)hbot=float(lm)-hbot+1.0 +! where(hbot /= spval .and. hbot > lm)hbot=lm*1.0 + if(debugprint)print*,'sample ',VarName,' = ',hbot(im/2,(jsta+jend)/2) + + VarName='htopd' + VcoordName='sfc' + l=1 + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,impf,jmpf,nframe,htopd) + where(htopd /= spval)htopd=float(lm)-htopd+1.0 +! where(htopd /= spval .and. htopd > lm)htopd=lm*1.0 + if(debugprint)print*,'sample ',VarName,' = ',htopd(im/2,(jsta+jend)/2) + + VarName='hbotd' + VcoordName='sfc' + l=1 + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,impf,jmpf,nframe,hbotd) + where(hbotd /= spval)hbotd=float(lm)-hbotd+1.0 +! where(hbotd /= spval .and. hbotd > lm)hbotd=lm*1.0 + if(debugprint)print*,'sample ',VarName,' = ',hbotd(im/2,(jsta+jend)/2) + + VarName='htops' + VcoordName='sfc' + l=1 + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,impf,jmpf,nframe,htops) + where(htops /= spval)htops=float(lm)-htops+1.0 +! where(htops /= spval .and. htops > lm)htops=lm*1.0 + if(debugprint)print*,'sample ',VarName,' = ',htops(im/2,(jsta+jend)/2) + + VarName='hbots' + VcoordName='sfc' + l=1 + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,impf,jmpf,nframe,hbots) + where(hbots /= spval)hbots=float(lm)-hbots+1.0 +! where(hbots /= spval .and. hbots > lm)hbots=lm*1.0 + if(debugprint)print*,'sample ',VarName,' = ',hbots(im/2,(jsta+jend)/2) + + VarName='cuppt' + VcoordName='sfc' + l=1 + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,impf,jmpf,nframe,cuppt) + if(debugprint)print*,'sample ',VarName,' = ',cuppt(im/2,(jsta+jend)/2) + + VarName='cprate' + VcoordName='sfc' + l=1 + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,impf,jmpf,nframe,cprate) + if(debugprint)print*,'sample ',VarName,' = ',cprate(im/2,(jsta+jend)/2) + +!!!! DONE GETTING + +!$omp parallel do private(i,j,l) + do l = 1, lm + do j = jsta, jend + do i = 1, im + IF(ABS(T(I,J,L))>1.0E-3 .and. (WH(I,J,1) < SPVAL)) & + OMGA(I,J,L) = -WH(I,J,L)*PMID(I,J,L)*G & + / (RD*T(I,J,L)*(1.+D608*Q(I,J,L))) + end do + end do + end do + + THL=210. + PLQ=70000. + + CALL TABLE(PTBL,TTBL,PT, & + RDQ,RDTH,RDP,RDTHE,PL,THL,QS0,SQS,STHE,THE0) + + CALL TABLEQ(TTBLQ,RDPQ,RDTHEQ,PLQ,THL,STHEQ,THE0Q) + +! +! + IF(ME==0)THEN + WRITE(6,*)' SPL (POSTED PRESSURE LEVELS) BELOW: ' + WRITE(6,51) (SPL(L),L=1,LSM) + 50 FORMAT(14(F4.1,1X)) + 51 FORMAT(8(F8.1,1X)) + ENDIF +! +! COMPUTE DERIVED TIME STEPPING CONSTANTS. +! +!MEB need to get DT +! DT = 120. !MEB need to get DT +! NPHS = 4 !MEB need to get physics DT + DTQ2 = DT * NPHS !MEB need to get physics DT + TSPH = 3600./DT !MEB need to get DT + + IF (PTHRESH > 0.) THEN + PTHRESH = 0.01*DTQ2/3.6E6 !-- Precip rate >= 0.01 mm/h +! PTHRESH = 0.01*DTQ2/(3600.*39.37) !-- Precip rate >= 0.01 inches/h + ENDIF + + TSRFC=float(NSRFC)/TSPH + if(me==0)write(6,*)'tsfrc ',tsrfc,nsrfc,tsph + IF(NSRFC==0)TSRFC=float(ifhr) !in case buket does not get emptied + TRDLW=float(NRDLW)/TSPH + IF(NRDLW==0)TRDLW=float(ifhr) !in case buket does not get emptied + TRDSW=float(NRDSW)/TSPH + IF(NRDSW==0)TRDSW=float(ifhr) !in case buket does not get emptied + THEAT=float(NHEAT)/TSPH + IF(NHEAT==0)THEAT=float(ifhr) !in case buket does not get emptied + TCLOD=float(NCLOD)/TSPH + IF(NCLOD==0)TCLOD=float(ifhr) !in case buket does not get emptied + TPREC=float(NPREC)/TSPH + IF(NPREC==0)TPREC=float(ifhr) !in case buket does not get emptied +! TPREC=float(ifhr) + if(me==0)print*,'TSRFC TRDLW TRDSW THEAT TCLOD TPREC= ' & + ,TSRFC, TRDLW, TRDSW, THEAT, TCLOD, TPREC +!MEB need to get DT + +!how am i going to get this information? +! 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) +!how am i going to get this information? +! +! IF(ME==0)THEN +! WRITE(6,*)' ' +! WRITE(6,*)'DERIVED TIME STEPPING CONSTANTS' +! WRITE(6,*)' NPREC,NHEAT,NSRFC : ',NPREC,NHEAT,NSRFC +! WRITE(6,*)' NCLOD,NRDSW,NRDLW : ',NCLOD,NRDSW,NRDLW +! ENDIF +! +! COMPUTE DERIVED MAP OUTPUT CONSTANTS. + DO L = 1,LSM + ALSL(L) = ALOG(SPL(L)) + END DO +! +!HC WRITE IGDS OUT FOR WEIGHTMAKER TO READ IN AS KGDSIN + if(me==0)then + print*,'writing out igds' + igdout=110 +! open(igdout,file='griddef.out',form='unformatted' +! + ,status='unknown') + IF(MAPTYPE==203)THEN !A STAGGERED E-GRID + WRITE(igdout)203 + WRITE(igdout)im + WRITE(igdout)jm + WRITE(igdout)LATSTART + WRITE(igdout)LONSTART + WRITE(igdout)136 + WRITE(igdout)CENLAT + WRITE(igdout)CENLON + WRITE(igdout)DXVAL + WRITE(igdout)DYVAL + WRITE(igdout)64 + WRITE(igdout)0 + WRITE(igdout)0 + WRITE(igdout)0 + WRITE(igdout)LATLAST + WRITE(igdout)LONLAST + ELSE IF(MAPTYPE==205)THEN !A STAGGERED B-GRID + WRITE(igdout)205 + WRITE(igdout)im + WRITE(igdout)jm + WRITE(igdout)LATSTART + WRITE(igdout)LONSTART + WRITE(igdout)136 + WRITE(igdout)CENLAT + WRITE(igdout)CENLON + WRITE(igdout)DXVAL + WRITE(igdout)DYVAL + WRITE(igdout)64 + WRITE(igdout)LATLAST + WRITE(igdout)LONLAST + WRITE(igdout)0 + WRITE(igdout)0 + WRITE(igdout)0 + END IF + open(111,file='copygb_gridnav.txt',form='formatted' & + ,status='unknown') + IF(MAPTYPE==203)THEN !A STAGGERED E-GRID + write(111,1000) 2*IM-1,JM,LATSTART,LONSTART,CENLON, & + NINT(dxval*107.),NINT(dyval*110.),CENLAT,CENLAT + ELSE IF(MAPTYPE==205)THEN !A STAGGERED B-GRID + if(grib=="grib2") then + write(111,1000) IM,JM,LATSTART/1000,LONSTART/1000,CENLON/1000, & + NINT(dxval*107.)/1000,NINT(dyval*110.)/1000, & + CENLAT/1000,CENLAT/1000, & + LATLAST/1000,LONLAST/1000 + endif + END IF +1000 format('255 3 ',2(I4,x),I6,x,I7,x,'8 ',I7,x,2(I6,x),'0 64', & + 3(x,I6),x,I7) + close(111) +! + IF (MAPTYPE==205)THEN !A STAGGERED B-GRID + open(112,file='latlons_corners.txt',form='formatted' & + ,status='unknown') + if(grib=="grib2") then + write(112,1001)LATSTART/1000,(LONSTART/1000)-360000, & + LATSE/1000, & + LONSE/1000,LATNW/1000,LONNW/1000,LATLAST/1000, & + (LONLAST/1000)-360000 + endif +1001 format(4(I6,x,I7,x)) + close(112) + ENDIF + + end if + +! close all files + call nemsio_close(nfile,iret=status) +! + if(me==0)write(0,*)'end of INIT_NEMS' + + RETURN + END diff --git a/sorc/ncep_post.fd/INITPOST_NMM.f b/sorc/ncep_post.fd/INITPOST_NMM.f deleted file mode 100644 index c673aa5fb..000000000 --- a/sorc/ncep_post.fd/INITPOST_NMM.f +++ /dev/null @@ -1,2643 +0,0 @@ -!> @file -! -!> SUBPROGRAM: INITPOST INITIALIZE POST FOR RUN -!! PRGRMMR: RUSS TREADON ORG: W/NP2 DATE: 93-11-10 -!! -!! ABSTRACT: THIS ROUTINE INITIALIZES CONSTANTS AND -!! VARIABLES AT THE START OF AN ETA MODEL OR POST -!! PROCESSOR RUN. -!! -!! THIS ROUTINE ASSUMES THAT INTEGERS AND REALS ARE THE SAME SIZE -!! -!! PROGRAM HISTORY LOG: -!! 93-11-10 RUSS TREADON - ADDED DOCBLOC -!! 98-05-29 BLACK - CONVERSION OF POST CODE FROM 1-D TO 2-D -!! 99-01 20 TUCCILLO - MPI VERSION -!! 01-10-25 H CHUANG - MODIFIED TO PROCESS HYBRID MODEL OUTPUT -!! 02-06-19 MIKE BALDWIN - WRF VERSION -!! 02-08-15 H CHUANG - UNIT CORRECTION AND GENERALIZE PROJECTION OPTIONS -!! 03-07-25 H CHUANG - MODIFIED TO PROCESS NMM WRF -!! 05-12-05 H CHUANG - ADD CAPABILITY TO OUTPUT OFF-HOUR FORECAST WHICH HAS -!! NO INPACTS ON ON-HOUR FORECAST -!! 21-03-11 Bo Cui - change local arrays to dimension (im,jsta:jend) -!! -!! USAGE: CALL INIT -!! INPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - CTLBLK -!! LOOKUP -!! SOILDEPTH -!! -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : CRAY C-90 -!! - SUBROUTINE INITPOST_NMM - - use vrbls3d, only: t, u, uh, v, vh, q, cwm, f_ice, f_rain, f_rimef, q,& - qqw, qqr, qqs, qqi, qqg, qqw, cwm , q2, wh, pint, alpint, pmid,& - omga, pmidv, zmid, rlwtt, rswtt, ttnd, tcucn, train, exch_h,& - el_pbl, cfr, zint, REF_10CM, qqni, qqnr, qrimef - use vrbls2d, only: fis, cfrach, cfracl, cfracm, u10h, u10, v10h, v10,th10,& - q10, tshltr, qshltr, pshltr, smstav, smstot, acfrcv, acfrst, ncfrcv,& - ncfrst, ssroff, bgroff, sfcevp, sfcexc, vegfrc, acsnow, acsnom,& - cmc, sst, mdltaux, mdltauy, thz0, qz0, uz0, vz0, qs, z0, pblh, mixht,& - ustar, akhs, akms, ths, prec, cuprec, acprec, ancprc, cprate, cuppt,& - lspa, cldefi, htop, hbot, htopd, czmean, rswout, rlwin, rlwtoa, sigt4,& - radot, aswin, aswout, alwin, alwout, alwtoa, aswtoa, hbotd, htops,& - hbots, sr, rswin, rswinc, czen, tg, soiltb, twbs, sfcshx, qwbs,& - sfclhx, grnflx, subshx, potevp, sno, si, pctsno, ivgtyp, isltyp,& - islope, albedo, albase, mxsnal, epsr, f, REFC_10CM, REFD_MAX, & - RSWTOA, SWUPT, ACSWUPT, SWDNT, ACSWDNT, CD10, CH10 - use soil, only: smc, sh2o, stc, sldpth, sllevel - use masks, only: lmv, lmh, htm, vtm, hbm2, sm, sice, gdlat, gdlon, dx, dy - use params_mod, only: tfrz, g, rd, d608, rtd, dtr, erad - use lookup_mod, only: thl, plq, ptbl, ttbl, rdq, rdth, rdp, rdthe, pl,& - qs0, sqs, sthe, the0, ttblq, rdpq, rdtheq, stheq, the0q - use ctlblk_mod, only: jsta, jend, nprec, jsta_2l, jend_2u, filename,& - datahandle, datestr, ihrst, imin, sdat, spval, imp_physics, pt,& - icu_physics, pdtop, nsoil, isf_surface_physics, jsta_m, jend_m,& - avrain, avcnvc, ardsw, ardlw, asrfc, me, mpi_comm_comp, nphs, spl,& - lsm, dt, dtq2,tsrfc, trdlw, trdsw, idat, ifhr, ifmin, restrt,& - theat, tclod, tprec, alsl, lm, im, jm , submodelname - use gridspec_mod, only: latstart, latlast, cenlat, lonstart, lonlast,& - cenlon, dxval, dyval, maptype, gridtype, truelat1, truelat2,& - psmapf -! use wrf_io_flags_mod -! - implicit none -! -! INCLUDE/SET PARAMETERS. -! - INCLUDE "mpif.h" -! -! This version of INITPOST shows how to initialize, open, read from, and -! close a NetCDF dataset. In order to change it to read an internal (binary) -! dataset, do a global replacement of _ncd_ with _int_. - real :: dcenlat, dcenlon - character(len=31) :: VarName - integer :: Status, cen1, cen2 - character startdate*19,SysDepInfo*80 -! -! NOTE: SOME INTEGER VARIABLES ARE READ INTO DUMMY ( A REAL ). THIS IS OK -! AS LONG AS REALS AND INTEGERS ARE THE SAME SIZE. -! -! ALSO, EXTRACT IS CALLED WITH DUMMY ( A REAL ) EVEN WHEN THE NUMBERS ARE -! INTEGERS - THIS IS OK AS LONG AS INTEGERS AND REALS ARE THE SAME SIZE. - CHARACTER*4 RESTHR - INTEGER IDATE(8),JDATE(8) - INTEGER :: i_parent_start, j_parent_start -! -! DECLARE VARIABLES. -! - REAL RINC(5) - REAL ETA1(LM), ETA2(LM) - REAL DUMMY ( IM, JM ) -! REAL DUMMY2 ( IM, JM ) - real, allocatable :: fi(:,:,:) - REAL DUM3D ( IM+1, JM+1, LM+1 ) - REAL DUM3D2 ( IM+1, JM+1, LM+1 ) -!mp - INTEGER IDUMMY ( IM, JM ) -! -!jw - integer ii,jj,js,je,jev,iyear,imn,iday,itmp,ioutcount,istatus, & - nsrfc,nrdlw,nrdsw,nheat,nclod, & - I,J,L,LL,N,LONEND,LATEND,IMM,INAV,IRTN, & - IFDX,IFDY,IGDOUT,ICEN,JCEN -! integer iw, ie - real TSPH,fact,dumcst,tstart,tmp - real LAT -! -! Declarations for : -! putting 10 m wind on V points because copygb assume such - INTEGER IE, IW -!code from R.Rozumalski - INTEGER latnm, latsm, lonem, lonwm, idxave, dlat, dlon, nlat, nlon - -!*********************************************************************** -! START INIT HERE. -! - WRITE(6,*)'INITPOST: ENTER INITPOST' - print*,'im,jm,lm= ',im,jm,lm - - ii=im/2 ! diagnostic print indices - jj=(jsta+jend)/2 - ll=lm/2 -! -! STEP 1. READ MODEL OUTPUT FILE -! -! -!*** -! -! set default to not empty buket - NSRFC=0 - NRDLW=0 - NRDSW=0 - NHEAT=0 - NCLOD=0 - NPREC=0 - -! LMH always = LM for sigma-type vert coord -! LMV always = LM for sigma-type vert coord - - do j = jsta_2l, jend_2u - do i = 1, im - LMV ( i, j ) = lm - LMH ( i, j ) = lm - end do - end do - - -! HTM VTM all 1 for sigma-type vert coord - - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - HTM ( i, j, l ) = 1.0 - VTM ( i, j, l ) = 1.0 - end do - end do - end do -! -! how do I get the filename? -! fileName = '/ptmp/wx20mb/wrfout_01_030500' -! DateStr = '2002-03-05_18:00:00' -! how do I get the filename? - call ext_ncd_ioinit(SysDepInfo,Status) - print*,'called ioinit', Status - call ext_ncd_open_for_read( trim(fileName), 0, 0, " ", & - DataHandle, Status) - print*,'called open for read', Status - if ( Status /= 0 ) then - print*,'error opening ',fileName, ' Status = ', Status ; stop - endif -! get date/time info -! this routine will get the next time from the file, not using it - print *,'DateStr before calling ext_ncd_get_next_time=',DateStr -! call ext_ncd_get_next_time(DataHandle, DateStr, Status) - print *,'DateStri,Status,DataHandle = ',DateStr,Status,DataHandle - -! The end j row is going to be jend_2u for all variables except for V. - JS=JSTA_2L - JE=JEND_2U - IF (JEND_2U==JM) THEN - JEV=JEND_2U+1 - ELSE - JEV=JEND_2U - ENDIF -! -! Getting start time - call ext_ncd_get_dom_ti_char(DataHandle,'START_DATE',startdate, & - status ) -! patch for NMM WRF because it does not have start-date in output yet -! startdate='2003-04-17T00:00:00' - print*,'startdate= ',startdate -! - jdate=0 - idate=0 - read(startdate,15)iyear,imn,iday,ihrst,imin - 15 format(i4,1x,i2,1x,i2,1x,i2,1x,i2) - print*,'start yr mo day hr min =',iyear,imn,iday,ihrst,imin - print*,'processing yr mo day hr min=',idat(3),idat(1),idat(2), & - idat(4),idat(5) - idate(1)=iyear - idate(2)=imn - idate(3)=iday - idate(5)=ihrst - idate(6)=imin - SDAT(1)=imn - SDAT(2)=iday - SDAT(3)=iyear -! - jdate(1)=idat(3) - jdate(2)=idat(1) - jdate(3)=idat(2) - jdate(5)=idat(4) - jdate(6)=idat(5) -! CALL W3DIFDAT(JDATE,IDATE,2,RINC) -! ifhr=nint(rinc(2)) - CALL W3DIFDAT(JDATE,IDATE,0,RINC) - ifhr=nint(rinc(2)+rinc(1)*24.) - ifmin=nint(rinc(3)) - print*,' in INITPOST ifhr ifmin fileName=',ifhr,ifmin,fileName - -! Getting tstart - call ext_ncd_get_dom_ti_real(DataHandle,'TSTART',tmp,1,ioutcount, & - istatus) - if(istatus==0)then - tstart=tmp - else - tstart=0. - end if - print*,'status for getting TSTART= ',istatus - print*,'TSTART= ',TSTART - -! Getting restart - - RESTRT=.TRUE. ! set RESTRT default - call ext_ncd_get_dom_ti_integer(DataHandle,'RESTARTBIN',itmp,1, & - ioutcount,istatus) - - IF(itmp < 1)THEN - RESTRT=.FALSE. - ELSE - RESTRT=.TRUE. - END IF - - print*,'status for getting RESTARTBIN= ',istatus - print*,'Is this a restrt run? ',RESTRT - -! IF(RESTRT)THEN -! ifhr=ifhr+NINT(tstart) -! print*,'new forecast hours for restrt run= ',ifhr -! END IF - - IF(tstart > 1.0E-2)THEN - ifhr=ifhr+NINT(tstart) - rinc=0 - idate=0 - rinc(2)=-1.0*ifhr - call w3movdat(rinc,jdate,idate) - SDAT(1)=idate(2) - SDAT(2)=idate(3) - SDAT(3)=idate(1) - IHRST=idate(5) - print*,'new forecast hours for restrt run= ',ifhr - print*,'new start yr mo day hr min =',sdat(3),sdat(1), & - sdat(2),ihrst,imin - END IF - - VarName='HBM2' - HBM2=SPVAL - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - HBM2 ( i, j ) = dummy ( i, j ) - end do - end do - -! OK, since all of the variables are dimensioned/allocated to be -! the same size, this means we have to be careful int getVariable -! to not try to get too much data. For example, -! DUM3D is dimensioned IM+1,JM+1,LM+1 but there might actually -! only be im,jm,lm points of data available for a particular variable. - -! get 3-D variables - VarName='T' - call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, & - IM+1,1,JM+1,LM+1,IM,JS,JE,LM) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - t ( i, j, l ) = dum3d ( i, j, l ) -! if(l==1)print*,'Debug: I,J,T= ',i,j,t ( i, j, l ) -! t ( i, j, l ) = dum3d ( i, j, l ) + 300. -! th ( i, j, l ) = dum3d ( i, j, l ) + 300. - end do - end do - end do - do l=1,lm - if(jj>= jsta .and. jj<=jend)print*,'sample L,T= ',L,T(ii,jj,l) - end do - -! VarName='T_ADJ' -! call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, -! & IM+1,1,JM+1,LM+1,IM,JS,JE,LM) -! do l = 1, lm -! do j = jsta_2l, jend_2u -! do i = 1, im -! t_ADJ ( i, j, l ) = dum3d ( i, j, l ) -! end do -! end do -! end do -! do l=1,lm -! if(jj>= jsta .and. jj<=jend)print*,'sample L,T_ADJ= ',L -! &,T_ADJ(ii,jj,l) -! end do - - - VarName='U' - call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, & - IM+1,1,JM+1,LM+1,IM,JS,JE,LM) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - u ( i, j, l ) = dum3d ( i, j, l ) - UH( i, j, l ) = dum3d ( i, j, l ) -! if(l==1)print*,'Debug: I,J,U= ',i,j,u( i, j, l ) - end do - end do -! fill up UH which is U at P-points including 2 row halo -! do j = jsta_2l, jend_2u -! do i = 1, im -! UH (I,J,L) = (dum3d(I,J,L)+dum3d(I+1,J,L))*0.5 -! end do -! end do - end do - if(jj>= jsta .and. jj<=jend)print*,'sample U= ',U(ii,jj,ll) - VarName='V' - call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, & - IM+1,1,JM+1,LM+1,IM,JS,JE,LM) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - v ( i, j, l ) = dum3d ( i, j, l ) - VH( i, j, l ) = dum3d ( i, j, l ) - end do - end do -! fill up VH which is V at P-points including 2 row halo -! do j = jsta_2l, jend_2u -! do i = 1, im -! VH(I,J,L) = (dum3d(I,J,L)+dum3d(I,J+1,L))*0.5 -! end do -! end do - end do - if(jj>= jsta .and. jj<=jend)print*,'sample V= ',V(ii,jj,ll) - - call ext_ncd_get_dom_ti_integer(DataHandle,'MP_PHYSICS' & - ,itmp,1,ioutcount,istatus) - imp_physics=itmp -! Chuang: will initialize microphysics constants differently for 85 now -! if(imp_physics == 85) imp_physics=5 !HWRF - print*,'MP_PHYSICS= ',imp_physics - -! Initializes constants for Ferrier microphysics - if(imp_physics==5 .or. imp_physics==15 .or. imp_physics==85 & - .or. imp_physics==95)then - CALL MICROINIT(imp_physics) - end if - - call ext_ncd_get_dom_ti_integer(DataHandle,'CU_PHYSICS' & - ,itmp,1,ioutcount,istatus) - icu_physics=itmp - if (icu_physics == 84 .or. icu_physics == 85) icu_physics = 4 ! HWRF - print*,'CU_PHYSICS= ',icu_physics - - ! Set these values to SPVAL to insure they are initialized a - ! fact that the code relies on later.... - qqw=spval - qqr=spval - qqs=spval - qqi=spval - qqg=spval - -!KRF: NMM and ARW direct read of radar ref for microphysic options -! mp options: 2,4,6,7,8,10,14,16 -! REFL_10cm --> REF_10CM -! REFD_MAX --> REFD_MAX - VarName='REFL_10CM' - call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, & - IM+1,1,JM+1,LM+1,IM,JS,JE,LM) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - REF_10CM ( i, j, l ) = dum3d ( i, j, l ) - end do - end do - end do - do l=1,lm - if(jj>= jsta .and. jj<=jend)print*,'sample L,T= ',L,T(ii,jj,l) - end do - - VarName='REFD_MAX' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - REFD_MAX ( i, j ) = dummy ( i, j ) - end do - end do -! print*,'REFD_MAX at ',ii,jj,' = ',REFD_MAX(ii,jj) -! END KRF - - if(imp_physics==5 .or. imp_physics==15 .or. imp_physics==85 .or. imp_physics==95)then - - VarName='Q' - call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, & - IM+1,1,JM+1,LM+1,IM,JS,JE,LM) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - if (dum3d(i,j,l) < 10E-12) dum3d(i,j,l) = 10E-12 - q ( i, j, l ) = dum3d ( i, j, l ) - end do - end do - end do - print*,'finish reading specific humidity' - if(jj>= jsta .and. jj<=jend)print*,'sample Q= ',Q(ii,jj,ll) - - else - VarName='QVAPOR' - call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, & - IM+1,1,JM+1,LM+1,IM,JS,JE,LM) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im -! q ( i, j, l ) = dum3d ( i, j, l ) -! if(l==1)print*,'Debug: I,J,Q= ',i,j,q( i, j, l ) -!CHC CONVERT MIXING RATIO TO SPECIFIC HUMIDITY - if (dum3d(i,j,l) < 10E-12) dum3d(i,j,l) = 10E-12 - q ( i, j, l ) = dum3d ( i, j, l )/(1.0+dum3d ( i, j, l )) - end do - end do - end do - print*,'finish reading specific humidity' - if(jj>= jsta .and. jj<=jend)print*,'sample Q= ',Q(ii,jj,ll) - endif - - if(imp_physics==5 .or. imp_physics==85 .or. imp_physics==95)then - VarName='CWM' !????? - call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, & - IM+1,1,JM+1,LM+1,IM,JS,JE,LM) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - cwm ( i, j, l ) = dum3d ( i, j, l ) - end do - end do - end do - print*,'finish reading cloud mixing ratio' - - VarName='F_ICE' - call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, & - IM+1,1,JM+1,LM+1,IM,JS,JE,LM) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - F_ICE ( i, j, l ) = dum3d ( i, j, l ) - end do - end do - end do - - VarName='F_RAIN' - call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, & - IM+1,1,JM+1,LM+1,IM,JS,JE,LM) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - F_RAIN ( i, j, l ) = dum3d ( i, j, l ) - end do - end do - end do - - VarName='F_RIMEF' - call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, & - IM+1,1,JM+1,LM+1,IM,JS,JE,LM) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - F_RIMEF ( i, j, l ) = dum3d ( i, j, l ) - end do - end do - end do - - else ! retrieve hydrometeo fields directly for non-Ferrier - cwm=spval !make sure set - F_RimeF=spval !make sure set - - if(imp_physics/=0)then - VarName='QCLOUD' - call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, & - IM+1,1,JM+1,LM+1,IM,JS,JE,LM) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im -! partition cloud water and ice for WSM3 - if(imp_physics==3)then - if(t(i,j,l) >= TFRZ)then - qqw ( i, j, l ) = dum3d ( i, j, l ) - else - qqi ( i, j, l ) = dum3d ( i, j, l ) - end if - else ! bug fix provided by J CASE - qqw ( i, j, l ) = dum3d ( i, j, l ) - end if - cwm(i,j,l)=dum3d(i,j,l) - end do - end do - end do - end if - if(jj>= jsta .and. jj<=jend)print*,'sample qqw= ' & - ,Qqw(ii,jj,ll) - - if(imp_physics/=1 .and. imp_physics/=3 & - .and. imp_physics/=0)then - VarName='QICE' - call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, & - IM+1,1,JM+1,LM+1,IM,JS,JE,LM) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - qqi ( i, j, l ) = dum3d ( i, j, l ) - cwm(i,j,l)=cwm(i,j,l)+dum3d(i,j,l) - end do - end do - end do - end if - if(jj>= jsta .and. jj<=jend)print*,'sample qqi= ' & - ,Qqi(ii,jj,ll) - - if(imp_physics==15) then - VarName='QRIMEF' - call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, & - IM+1,1,JM+1,LM+1,IM,JS,JE,LM) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - qrimef ( i, j, l ) = dum3d ( i, j, l ) - end do - end do - end do - end if - if(jj>= jsta .and. jj<=jend)print*,'sample qrimef= ' & - ,Qrimef(ii,jj,ll) - - if(imp_physics/=0)then - VarName='QRAIN' - call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, & - IM+1,1,JM+1,LM+1,IM,JS,JE,LM) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im -! partition rain and snow for WSM3 - if(imp_physics == 3)then - if(t(i,j,l) >= TFRZ)then - qqr ( i, j, l ) = dum3d ( i, j, l ) - else - qqs ( i, j, l ) = dum3d ( i, j, l ) - end if - else ! bug fix provided by J CASE - qqr ( i, j, l ) = dum3d ( i, j, l ) - end if - cwm(i,j,l)=cwm(i,j,l)+dum3d(i,j,l) - end do - end do - end do - end if - if(jj>= jsta .and. jj<=jend)print*,'sample qqr= ' & - ,Qqr(ii,jj,ll) - - if(imp_physics/=1 .and. imp_physics/=3 & - .and. imp_physics/=0)then - VarName='QSNOW' - call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, & - IM+1,1,JM+1,LM+1,IM,JS,JE,LM) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - qqs ( i, j, l ) = dum3d ( i, j, l ) - cwm(i,j,l)=cwm(i,j,l)+dum3d(i,j,l) - end do - end do - end do - end if - if(jj>= jsta .and. jj<=jend)print*,'sample qqs= ' & - ,Qqs(ii,jj,ll) - - if(imp_physics==2 .or. imp_physics==6 & - .or. imp_physics==8 .or. imp_physics==28)then - VarName='QGRAUP' - call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, & - IM+1,1,JM+1,LM+1,IM,JS,JE,LM) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - qqg ( i, j, l ) = dum3d ( i, j, l ) - cwm(i,j,l)=cwm(i,j,l)+dum3d(i,j,l) - end do - end do - end do - end if - if(jj>= jsta .and. jj<=jend)print*,'sample qqg= ' & - ,Qqg(ii,jj,ll) - -! KRS: Add concentrations for HWRF output - if(imp_physics==8 .or. imp_physics==9)then - VarName='QNICE' - call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, & - IM+1,1,JM+1,LM+1,IM, JS,JE,LM) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - qqni ( i, j, l ) = dum3d ( i, j, l ) - if(i==im/2.and.j==(jsta+jend)/2)print*,'sample QQNI= ', & - i,j,l,QQNI ( i, j, l ) - end do - end do - end do - VarName='QNRAIN' - call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, & - IM+1,1,JM+1,LM+1,IM, JS,JE,LM) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - qqnr ( i, j, l ) = dum3d ( i, j, l ) - if(i==im/2.and.j==(jsta+jend)/2)print*,'sample QQNR= ', & - i,j,l,QQNR ( i, j, l ) - end do - end do - end do - end if -! KRS: End add concentrations for HWRF - - end if ! end of retrieving hydrometeo for different MP options - - -! call getVariable(fileName,DateStr,DataHandle,'TKE_PBL',DUM3D, - call getVariable(fileName,DateStr,DataHandle,'Q2',DUM3D, & - IM+1,1,JM+1,LM+1,IM,JS,JE,LM) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - q2 ( i, j, l ) = dum3d ( i, j, l ) - end do - end do - end do - VarName='W' - call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, & - IM+1,1,JM+1,LM+1,IM,JS,JE,LM+1) -! & IM+1,1,JM+1,LM+1,IM,JS,JE,LM) -! do l = 1, lm+1 -! do j = jsta_2l, jend_2u -! do i = 1, im -! w ( i, j, l ) = dum3d ( i, j, l ) -! end do -! end do -! end do -! fill up WH which is W at P-points including 2 row halo - DO L=1,LM - DO I=1,IM - DO J=JSTA_2L,JEND_2U -! WH(I,J,L) = (W(I,J,L)+W(I,J,L+1))*0.5 - wh ( i, j, l ) = dum3d ( i, j, l+1 ) - ENDDO - ENDDO - ENDDO - print*,'finish reading W' - -!MEB call getVariable(fileName,DateStr,DataHandle,'QRAIN',new) - - VarName='PINT' - call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, & - IM+1,1,JM+1,LM+1,IM,JS,JE,LM+1) -! VarName='P' -! call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D2, -! & IM+1,1,JM+1,LM+1,IM,JS,JE,LM) - do l = 1, lm+1 - do j = jsta_2l, jend_2u - do i = 1, im -! PMID(I,J,L)=DUM3D(I,J,L)+DUM3D2(I,J,L) - PINT(I,J,L)=DUM3D(I,J,L) - ALPINT(I,J,L)=ALOG(PINT(I,J,L)) - end do - end do - end do -! do l = 1, lm+1 -! if(jj>= jsta .and. jj<=jend)print*,'sample PINT= ' -! & ,PINT(ii,jj,l) -! end do -! - DO L=1,LM - DO I=1,IM - DO J=JSTA_2L,JEND_2U - PMID(I,J,L)=(PINT(I,J,L)+PINT(I,J,L+1))*0.5 -! TH(I,J,L)=T(I,J,L)*(1.E5/PMID(I,J,L))**CAPA - IF(ABS(T(I,J,L))>1.0E-3) & - OMGA(I,J,L) = -WH(I,J,L)*PMID(I,J,L)*G/ & - (RD*T(I,J,L)*(1.+D608*Q(I,J,L))) -! -! PINT(I,J,L)=EXP((ALOG(PMID(I,J,L-1))+ -! & ALOG(PMID(I,J,L)))*0.5) ! ave of ln p -! ALPINT(I,J,L)=ALOG(PINT(I,J,L)) - ENDDO - ENDDO - ENDDO -! - do l = 1, lm - do j = jsta, jend - do i = 1, im-MOD(J,2) - IF(J == 1 .AND. I < IM)THEN !SOUTHERN BC - PMIDV(I,J,L)=0.5*(PMID(I,J,L)+PMID(I+1,J,L)) - ELSE IF(J==JM .AND. I1.0e-5)print*,'nonzero ncfrcv',ncfrcv(i,j) - end do - end do - - VarName='NCFRST' - write(6,*) 'call getIVariable for : ', VarName - call getIVariableN(fileName,DateStr,DataHandle,VarName,IDUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - ncfrst ( i, j ) = float(idummy ( i, j )) -! if(ncfrst(i,j)>1.0e-5)print*,'nonzero ncfrst',ncfrst(i,j) - end do - end do - - VarName='SSROFF' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - SSROFF ( i, j ) = dummy ( i, j ) - end do - end do - VarName='UDROFF' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - BGROFF ( i, j ) = dummy ( i, j ) - end do - end do - - VarName='SFCEVP' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - SFCEVP( i, j ) = dummy ( i, j ) - end do - end do -! print*,'SFCEVP at ',ii,jj,' = ',SFCEVP(ii,jj) - - VarName='CD10' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY,& - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - CD10( i, j ) = dummy ( i, j ) - end do - end do -! print*,'CD10 at ',ii,jj,' = ',CD10(ii,jj) - - VarName='CH10' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY,& - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - CH10( i, j ) = dummy ( i, j ) - end do - end do -! print*,'CD10 at ',ii,jj,' = ',CD10(ii,jj) - - VarName='SFCEXC' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - SFCEXC( i, j ) = dummy ( i, j ) - end do - end do -! print*,'SFCEXC at ',ii,jj,' = ',SFCEXC(ii,jj) - VarName='VEGFRC' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - VEGFRC ( i, j ) = dummy ( i, j ) - end do - end do - print*,'VEGFRC at ',ii,jj,' = ',VEGFRC(ii,jj) - VarName='ACSNOW' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - ACSNOW ( i, j ) = dummy ( i, j ) - end do - end do - VarName='ACSNOM' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - ACSNOM ( i, j ) = dummy ( i, j ) - end do - end do -! VarName='CANWAT' - VarName='CMC' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - CMC ( i, j ) = dummy ( i, j ) - end do - end do - VarName='SST' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - SST ( i, j ) = dummy ( i, j ) - end do - end do - print*,'SST at ',ii,jj,' = ',sst(ii,jj) - - VarName='TAUX' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - MDLTAUX ( i, j ) = dummy ( i, j ) - end do - end do - print*,'MDLTAUX at ',ii,jj,' = ',mdltaux(ii,jj) - - VarName='TAUY' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - MDLTAUY ( i, j ) = dummy ( i, j ) - end do - end do - print*,'MDLTAUY at ',ii,jj,' = ',mdltauy(ii,jj) - - VarName='EXCH_H' - call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, & - IM+1,1,JM+1,LM+1,IM,JS,JE,LM) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - EXCH_H ( i, j, l ) = dum3d ( i, j, l ) - dummy(i,j)=dum3d ( i, j, l ) - end do - end do - print*,'l, max exch = ',l,maxval(dummy) - end do - do l=1,lm - print*,'sample EXCH_H= ',EXCH_H(ii,jj,l) - end do - - VarName='EL_PBL' - call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, & - IM+1,1,JM+1,LM+1,IM,JS,JE,LM) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - EL_PBL ( i, j, l ) = dum3d ( i, j, l ) - dummy(i,j)=dum3d ( i, j, l ) - end do - end do - print*,'l, max EL_PBL = ',l,maxval(dummy) - end do - - - VarName='THZ0' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - THZ0 ( i, j ) = dummy ( i, j ) - end do - end do - print*,'THZ0 at ',ii,jj,' = ',THZ0(ii,jj) - VarName='QZ0' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - QZ0 ( i, j ) = dummy ( i, j ) - end do - end do - print*,'QZ0 at ',ii,jj,' = ',QZ0(ii,jj) - VarName='UZ0' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - UZ0 ( i, j ) = dummy ( i, j ) - end do - end do - print*,'UZ0 at ',ii,jj,' = ',UZ0(ii,jj) - VarName='VZ0' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - VZ0 ( i, j ) = dummy ( i, j ) - end do - end do - print*,'VZ0 at ',ii,jj,' = ',VZ0(ii,jj) -! VarName='QSFC' - VarName='QS' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - QS ( i, j ) = dummy ( i, j ) -! if(qs(i,j)>1.0e-7)print*,'nonzero qsfc' - end do - end do - - VarName='Z0' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - Z0 ( i, j ) = dummy ( i, j ) - end do - end do - - VarName='PBLH' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - PBLH( i, j ) = dummy ( i, j ) - end do - end do -! write(6,*) 'PBLH(ii,jj): ', DUMMY(ii,jj) - - VarName='MIXHT' !PLee (3/07) - MIXHT=SPVAL !Init value to detect read failure - call getVariable(filename,DateStr,DataHandle,Varname,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - MIXHT( i, j ) = dummy ( i, j ) - end do - end do - - VarName='USTAR' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - USTAR( i, j ) = dummy ( i, j ) - end do - end do - - print*,'USTAR at ',ii,jj,' = ',USTAR(ii,jj) - VarName='AKHS_OUT' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - AKHS ( i, j ) = dummy ( i, j ) - end do - end do - print*,'max akhs= ',maxval(akhs) - VarName='AKMS_OUT' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - AKMS ( i, j ) = dummy ( i, j ) - end do - end do - print*,'max akms= ',maxval(akms) - -! -! In my version, variable is TSK (skin temp, not skin pot temp) -! -!mp call getVariable(fileName,DateStr,DataHandle,'THSK',DUMMY, -! VarName='TSK' - VarName='THS' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - THS ( i, j ) = dummy ( i, j ) - end do - end do - print*,'THS at ',ii,jj,' = ',THS(ii,jj) - -!C -!CMP -!C -!C RAINC is "ACCUMULATED TOTAL CUMULUS PRECIPITATION" -!C RAINNC is "ACCUMULATED TOTAL GRID SCALE PRECIPITATION" - - write(6,*) 'getting RAINC' - - VarName='PREC' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im -! CUPREC ( i, j ) = dummy ( i, j ) * 0.001 - PREC ( i, j ) = dummy ( i, j ) - end do - end do - print*,'PREC at ',ii,jj,' = ',PREC(ii,jj) - -! VarName='RAINC' - VarName='CUPREC' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im -! CUPREC ( i, j ) = dummy ( i, j ) * 0.001 - CUPREC ( i, j ) = dummy ( i, j ) - end do - end do - print*,'CUPREC at ',ii,jj,' = ',CUPREC(ii,jj) - write(6,*) 'getting RAINTOTAL' -! VarName='RAINNC' - VarName='ACPREC' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - ACPREC( i, j ) = dummy ( i, j ) - ANCPRC ( i, j ) = ACPREC(I,J)-CUPREC(I,J) - end do - end do - print*,'ACPREC at ',ii,jj,' = ',ACPREC(ii,jj) - print*,'ANCPRC at ',ii,jj,' = ',ANCPRC(ii,jj) -! -! hoping to read instantanous convective precip rate soon, initialize it to spval -! for now - - VarName='CPRATE' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - CPRATE(I,J)=dummy(i,j) - enddo - enddo - - VarName='CUPPT' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - CUPPT ( i, j ) = dummy ( i, j ) - end do - end do - print*,'maxval CUPPT: ', maxval(DUMMY) - -! adding land surface precipitation accumulation for Yin's precip assimilation - - VarName='LSPA' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - LSPA ( i, j ) = dummy ( i, j ) - end do - end do - print*,'maxval LSPA: ', maxval(DUMMY) - - - VarName='CLDEFI' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - CLDEFI ( i, j ) = dummy ( i, j ) - end do - end do - print*,'maxval CLDEFI: ', maxval(DUMMY) - -! -! Very confusing story ... -! -! Retrieve htop and hbot => They are named CNVTOP, CNVBOT in the model and -! with HBOTS,HTOPS (shallow conv) and HBOTD,HTOPD (deep conv) represent -! the 3 sets of convective cloud base/top arrays tied to the frequency -! that history files are written. -! -! IN THE *MODEL*, arrays HBOT,HTOP are similar to CNVTOP,CNVBOT but are -! used in radiation and are tied to the frequency of radiation updates. -! -! For historical reasons model arrays CNVTOP,CNVBOT are renamed HBOT,HTOP -! and manipulated throughout the post. - -! VarName='HTOP' - VarName='CNVTOP' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - HTOP ( i, j ) = float(LM)-dummy(i,j)+1.0 - HTOP ( i, j ) = max(1.0,min(HTOP(I,J),float(LM))) - end do - end do - print*,'maxval HTOP: ', maxval(DUMMY) - -! VarName='HBOT' - VarName='CNVBOT' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - HBOT ( i, j ) = float(LM)-dummy(i,j)+1.0 - HBOT ( i, j ) = max(1.0,min(HBOT(I,J),float(LM))) - end do - end do - print*,'maxval HBOT: ', maxval(DUMMY) - - VarName='HTOPD' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - HTOPD ( i, j ) = float(LM)-dummy(i,j)+1.0 - end do - end do - print*,'maxval HTOPD: ', maxval(DUMMY) - - VarName='HBOTD' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - HBOTD ( i, j ) = float(LM)-dummy(i,j)+1.0 - end do - end do - print*,'maxval HBOTD: ', maxval(DUMMY) - - VarName='HTOPS' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - HTOPS ( i, j ) = float(LM)-dummy(i,j)+1.0 - end do - end do - print*,'maxval HTOPS: ', maxval(DUMMY) - - VarName='HBOTS' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - HBOTS ( i, j ) = float(LM)-dummy(i,j)+1.0 - end do - end do - print*,'maxval HBOTS: ', maxval(DUMMY) - - VarName='CLDFRA' - call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, & - IM+1,1,JM+1,LM+1,IM,JS,JE,LM) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - CFR ( i, j, l ) = dum3d ( i, j, l ) - end do - end do - end do - - - VarName='SR' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - SR ( i, j ) = dummy(i,j) - end do - end do - print*,'maxval SR: ', maxval(DUMMY) - -! call getVariable(fileName,DateStr,DataHandle,'RAINCV',DUMMY, -! & IM,1,JM,1,IM,JS,JE,1) -! do j = jsta_2l, jend_2u -! do i = 1, im -! CUPPT ( i, j ) = dummy ( i, j )* 0.001 -! end do -! end do -! -! VarName='GSW' - VarName='RSWIN' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - RSWIN ( i, j ) = dummy ( i, j ) -! if(abs(dummy(i,j))> 0.0)print*,'rswin=',dummy(i,j) - end do - end do - - VarName='RSWINC' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - RSWINC ( i, j ) = dummy ( i, j ) -! if(abs(dummy(i,j))> 0.0)print*,'rswin=',dummy(i,j) - end do - end do - -! read in zenith angle - VarName='CZEN' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - CZEN ( i, j ) = dummy ( i, j ) -! if(abs(czen(i,j))> 0.0)print*,'czen=',czen(i,j) - end do - end do - - VarName='CZMEAN' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - CZMEAN ( i, j ) = dummy ( i, j ) -! if(abs(dummy(i,j))> 0.0)print*,'czmean=',dummy(i,j) - end do - end do - - VarName='RSWOUT' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - RSWOUT ( i, j ) = dummy ( i, j ) -! if(abs(dummy(i,j))> 0.0)print*,'rswout=',dummy(i,j) - end do - end do - -! VarName='GLW' - VarName='RLWIN' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - RLWIN ( i, j ) = dummy ( i, j ) - end do - end do - - VarName='RLWTOA' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - RLWTOA ( i, j ) = dummy ( i, j ) - end do - end do - - VarName='SIGT4' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - SIGT4 ( i, j ) = dummy ( i, j ) - end do - end do - - VarName='RADOT' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - RADOT ( i, j ) = dummy ( i, j ) - end do - end do - -! accumulated incoming short wave - VarName='ASWIN' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - ASWIN ( i, j ) = dummy ( i, j ) - end do - end do - -! accumulated outgoing short wave - VarName='ASWOUT' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - ASWOUT ( i, j ) = dummy ( i, j ) -! if(abs(dummy(i,j))> 0.0)print*,'aswout=',dummy(i,j) - end do - end do - -! shortwave accumulation frequency - VarName='NRDSW' - call getIVariableN(fileName,DateStr,DataHandle,VarName,NRDSW, & - 1,1,1,1,1,1,1,1) - print*,'NRDSW in INITPOST_NMM=',NRDSW - - VarName='ARDSW' - call getVariable(fileName,DateStr,DataHandle,VarName,ARDSW, & - 1,1,1,1,1,1,1,1) - print*,'ARDSW ARDLW in INITPOST_NMM=',ARDSW, ARDLW -! accumulated incoming long wave - VarName='ALWIN' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - ALWIN ( i, j ) = dummy ( i, j ) - end do - end do - -! accumulated outgoing long wave - VarName='ALWOUT' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - ALWOUT ( i, j ) = dummy ( i, j ) - end do - end do - -! longwave accumulation frequency - VarName='NRDLW' - call getIVariableN(fileName,DateStr,DataHandle,VarName,NRDLW, & - 1,1,1,1,1,1,1,1) - print*,'NRDLW= ',NRDLW - -! longwave accumulation counts - VarName='ARDLW' - call getVariable(fileName,DateStr,DataHandle,VarName,ARDLW, & - 1,1,1,1,1,1,1,1) - -! obtain time averaged radition at the top of atmosphere - VarName='ALWTOA' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - ALWTOA ( i, j ) = dummy ( i, j ) - end do - end do - - VarName='ASWTOA' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - ASWTOA ( i, j ) = dummy ( i, j ) - end do - end do - -! KRS: Add RSWTOA to radiation variable options - VarName='RSWTOA' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - RSWTOA ( i, j ) = dummy ( i, j ) - end do - end do - -! KRS: RRTMG variables for HWRF - VarName='SWUPT' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - SWUPT ( i, j ) = dummy ( i, j ) - end do - end do - - VarName='ACSWUPT' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - ACSWUPT ( i, j ) = dummy ( i, j ) - end do - end do - - VarName='SWDNT' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - SWDNT ( i, j ) = dummy ( i, j ) - end do - end do - - VarName='ACSWDNT' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - ACSWDNT ( i, j ) = dummy ( i, j ) - end do - end do - -! END KRS RRTMG Vars - - -! VarName='TMN' -! VarName='TG' - VarName='TGROUND' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - TG ( i, j ) = dummy ( i, j ) - end do - end do - - VarName='SOILTB' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - SOILTB ( i, j ) = dummy ( i, j ) - end do - end do - -! sensible heat fluxes - VarName='TWBS' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - TWBS ( i, j ) = dummy ( i, j ) - end do - end do - -! accumulated sensible heat fluxes -! VarName='HFX' - VarName='SFCSHX' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - SFCSHX ( i, j ) = dummy ( i, j ) - end do - end do - -! fluxes accumulation frequency - VarName='NSRFC' - call getIVariableN(fileName,DateStr,DataHandle,VarName,NSRFC, & - 1,1,1,1,1,1,1,1) - print*,'NSRFC= ',NSRFC -! fluxes accumulation counts - VarName='ASRFC' - call getVariable(fileName,DateStr,DataHandle,VarName,ASRFC, & - 1,1,1,1,1,1,1,1) - -! instantanous latent heat fluxes - VarName='QWBS' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - QWBS ( i, j ) = dummy ( i, j ) - end do - end do - -! accumulated latent heat fluxes -! VarName='QFX' - VarName='SFCLHX' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - SFCLHX ( i, j ) = dummy ( i, j ) - end do - end do - -! instantanous ground heat fluxes - VarName='GRNFLX' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - GRNFLX ( i, j ) = dummy ( i, j ) - end do - end do - -! accumulated ground heat fluxes - VarName='SUBSHX' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - SUBSHX ( i, j ) = dummy ( i, j ) - end do - end do - -! accumulated ground heat fluxes - VarName='POTEVP' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - POTEVP ( i, j ) = dummy ( i, j ) - end do - end do - -! VarName='SNOWC' -! VarName='SNO' - VarName='WEASD' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) -! do j = jsta_2l, jend_2u -! do i = 1, im -! SNO ( i, j ) = dummy ( i, j ) -! end do -! end do - - VarName='SNO' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - SNO ( i, j ) = dummy ( i, j ) - end do - end do - - VarName='SI' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - SI ( i, j ) = dummy ( i, j ) - end do - end do - -! snow cover - VarName='PCTSNO' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - PCTSNO ( i, j ) = dummy ( i, j ) - if(dummy(i,j) > 1.0e-5)print*,'nonzero pctsno' - end do - end do - - -! GET VEGETATION TYPE - -! call getVariable(fileName,DateStr,DataHandle,'IVGTYP',DUMMY -! & ,IM,1,JM,1,IM,JS,JE,1) -! print*,'sample VEG TYPE',DUMMY(20,20) -! XLAND 1 land 2 sea -! VarName='XLAND' - - VarName='IVGTYP' - call getIVariableN(fileName,DateStr,DataHandle,VarName,IDUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - IVGTYP ( i, j ) = idummy ( i, j ) - end do - end do - print*,'MAX IVGTYP=', maxval(idummy) - - VarName='ISLTYP' - call getIVariableN(fileName,DateStr,DataHandle,VarName,IDUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - ISLTYP ( i, j ) = idummy ( i, j ) - end do - end do - print*,'MAX ISLTYP=', maxval(idummy) - - VarName='ISLOPE' - call getIVariableN(fileName,DateStr,DataHandle,VarName,IDUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - ISLOPE( i, j ) = idummy ( i, j ) - end do - end do - - VarName='SM' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - SM ( i, j ) = dummy ( i, j ) - end do - end do - - VarName='SICE' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - SICE ( i, j ) = dummy ( i, j ) - end do - end do - - VarName='ALBEDO' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - ALBEDO( i, j ) = dummy ( i, j ) - end do - end do - - VarName='ALBASE' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - ALBASE( i, j ) = dummy ( i, j ) - end do - end do - - VarName='MXSNAL' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - MXSNAL( i, j ) = dummy ( i, j ) - end do - end do - - VarName='EPSR' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - EPSR( i, j ) = dummy ( i, j ) - end do - end do - -! VarName='XLAT' - VarName='GLAT' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - f(i,j) = 1.454441e-4*sin(dummy(i,j)) - GDLAT ( i, j ) = dummy ( i, j ) * RTD - end do - end do -! pos north - print*,'GDLAT at ',ii,jj,' = ',GDLAT(ii,jj) - print*,'read past GDLAT' -! VarName='XLONG' - VarName='GLON' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - GDLON ( i, j ) = dummy ( i, j ) * RTD -! if(j==1 .or. j==jm)print*,'I,J,GDLON,GDLAT= ',i,j -! 1 ,GDLON( i, j ),GDLAT ( i, j ) -! if(abs(GDLAT(i,j)-20.0)<0.5 .and. abs(GDLON(I,J) -! 1 +157.0)<5.)print* -! 2 ,'Debug:I,J,GDLON,GDLAT,SM,HGT,psfc= ',i,j,GDLON(i,j) -! 3 ,GDLAT(i,j),SM(i,j),FIS(i,j)/G,PINT(I,j,lm+1) - end do - end do - print*,'GDLON at ',ii,jj,' = ',GDLON(ii,jj) - print*,'read past GDLON' -! pos east - call collect_loc(gdlat,dummy) - get_dcenlat: if(me==0)then - latstart=nint(dummy(1,1)*1000.) ! lower left - latlast=nint(dummy(im,jm)*1000.) ! upper right - - icen=im/2 !center grid - jcen=jm/2 -print *, 'dummy(icen,jcen) = ', dummy(icen,jcen) -print *, 'dummy(icen-1,jcen) = ', dummy(icen-1,jcen) -print *, 'dummy(icen+1,jcen) = ', dummy(icen+1,jcen) - - ! Grid navigation for copygb - R.Rozumalski - latnm = nint(dummy(icen,jm)*1000.) - latsm = nint(dummy(icen,1)*1000.) -print *, 'latnm, latsm', latnm, latsm - - ! temporary patch for nmm wrf for moving nest - ! cenlat = glat(im/2,jm/2) -Gopal - - if(mod(im,2)/=0)then !per Pyle, jm is always odd - if(mod(jm+1,4)/=0)then - dcenlat=dummy(icen,jcen) - else - dcenlat=0.5*(dummy(icen-1,jcen)+dummy(icen,jcen)) - end if - else - if(mod(jm+1,4)/=0)then - dcenlat=0.5*(dummy(icen,jcen)+dummy(icen+1,jcen)) - else - dcenlat=dummy(icen,jcen) - end if - end if - endif get_dcenlat - write(6,*) 'laststart,latlast,dcenlat B calling bcast= ', & - latstart,latlast,dcenlat - call mpi_bcast(latstart,1,MPI_INTEGER,0,mpi_comm_comp,irtn) - call mpi_bcast(latlast,1,MPI_INTEGER,0,mpi_comm_comp,irtn) - call mpi_bcast(dcenlat,1,MPI_REAL,0,mpi_comm_comp,irtn) - write(6,*) 'laststart,latlast A calling bcast= ',latstart,latlast - - call collect_loc(gdlon,dummy) - get_dcenlon: if(me==0)then - lonstart=nint(dummy(1,1)*1000.) - lonlast=nint(dummy(im,jm)*1000.) - - ! icen, jcen set above -print *, 'lon dummy(icen,jcen) = ', dummy(icen,jcen) -print *, 'lon dummy(icen-1,jcen) = ', dummy(icen-1,jcen) -print *, 'lon dummy(icen+1,jcen) = ', dummy(icen+1,jcen) - - ! Grid navigation for copygb - R.Rozumalski - lonem = nint(dummy(icen,jm)*1000.) - lonwm = nint(dummy(icen,1)*1000.) - - if(mod(im,2)/=0)then !per Pyle, jm is always odd - if(mod(jm+1,4)/=0)then - cen1=dummy(icen,jcen) - cen2=cen1 - else - cen1=min(dummy(icen-1,jcen),dummy(icen,jcen)) - cen2=max(dummy(icen-1,jcen),dummy(icen,jcen)) - end if - else - if(mod(jm+1,4)/=0)then - cen1=min(dummy(icen+1,jcen),dummy(icen,jcen)) - cen2=max(dummy(icen+1,jcen),dummy(icen,jcen)) - else - cen1=dummy(icen,jcen) - cen2=cen1 - end if - end if - ! Trahan fix: Pyle's code broke at the dateline. - if(cen2-cen1>180) then - ! We're near the dateline - dcenlon=mod(0.5*(cen2+cen1+360)+3600+180,360.)-180. - else - ! We're not near the dateline. Use the original code, - ! unmodified, to maintain bitwise identicality. - dcenlon=0.5*(cen1+cen2) - endif - end if get_dcenlon ! rank 0 - write(6,*)'lonstart,lonlast,cenlon B calling bcast= ',lonstart, & - lonlast,cenlon - call mpi_bcast(lonstart,1,MPI_INTEGER,0,mpi_comm_comp,irtn) - call mpi_bcast(lonlast,1,MPI_INTEGER,0,mpi_comm_comp,irtn) - call mpi_bcast(dcenlon,1,MPI_REAL,0,mpi_comm_comp,irtn) - write(6,*)'lonstart,lonlast,cenlon A calling bcast= ',lonstart, & - lonlast,cenlon - - if(me==0) then - open(1013,file='this-domain-center.ksh.inc',form='formatted',status='unknown') -1013 format(A,'=',F0.3) - write(1013,1013) 'clat',dcenlat - write(1013,1013) 'clon',dcenlon - endif -! -! OBTAIN DX FOR NMM WRF - VarName='DX_NMM' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - DX ( i, j ) = dummy ( i, j ) - if(DX(i,j)<0.1)print*,'zero dx in INIT: I,J,DX= ',i,j & - ,DX( i, j ) -! if(j==1 .or. j==jm)print*,'I,J,DX= ',i,j -! 1 ,DX( i, j ) - end do - end do - - varname='ETA1' - write(6,*) 'call getVariable for : ', VarName - call getVariable(fileName,DateStr,DataHandle,VarName,ETA1, & - LM,1,1,1,LM,1,1,1) - - varname='ETA2' - write(6,*) 'call getVariable for : ', VarName - call getVariable(fileName,DateStr,DataHandle,VarName,ETA2, & - LM,1,1,1,LM,1,1,1) - - open(75,file='ETAPROFILE.txt',form='formatted',status='unknown') - DO L=1,lm+1 - IF(L == 1)THEN - write(75,1020)L, 0., 0. - ELSE - write(75,1020)L, ETA1(lm+2-l), ETA2(lm+2-l) - END IF -! print*,'L, ETA1, ETA2= ',L, ETA1(l), ETA2(l) - END DO - 1020 format(I3,2E17.10) - close (75) - -! physics calling frequency - VarName='NPHS0' - call getIVariableN(fileName,DateStr,DataHandle,VarName,NPHS, & - 1,1,1,1,1,1,1,1) - print*,'NPHS= ',NPHS -! physics calling frequency - VarName='NCLOD' - call getIVariableN(fileName,DateStr,DataHandle,VarName,NCLOD, & - 1,1,1,1,1,1,1,1) - -! physics calling frequency - VarName='NPREC' - call getIVariableN(fileName,DateStr,DataHandle,VarName,NPREC, & - 1,1,1,1,1,1,1,1) - -! physics calling frequency - VarName='NHEAT' - call getIVariableN(fileName,DateStr,DataHandle,VarName,NHEAT, & - 1,1,1,1,1,1,1,1) - print*,'NHEAT= ',NHEAT - - ! Compute f_* arrays from q* arrays - if(imp_physics==15) then - print *,'Convert from Q arrays to F arrays for advected Ferrier.' - call etamp_q2f(QRIMEF,QQI,QQR,QQW,CWM,F_RAIN,F_ICE,F_RIMEF,T) - endif -! -! ncdump -h - -!! -!! -!! - write(6,*) 'filename in INITPOST=', filename,' is' - -! status=nf_open(filename,NF_NOWRITE,ncid) -! write(6,*) 'returned ncid= ', ncid -! status=nf_get_att_real(ncid,varid,'DX',tmp) -! dxval=int(tmp) -! status=nf_get_att_real(ncid,varid,'DY',tmp) -! dyval=int(tmp) -! status=nf_get_att_real(ncid,varid,'CEN_LAT',tmp) -! cenlat=int(1000.*tmp) -! status=nf_get_att_real(ncid,varid,'CEN_LON',tmp) -! cenlon=int(1000.*tmp) -! status=nf_get_att_real(ncid,varid,'TRUELAT1',tmp) -! truelat1=int(1000.*tmp) -! status=nf_get_att_real(ncid,varid,'TRUELAT2',tmp) -! truelat2=int(1000.*tmp) -! status=nf_get_att_real(ncid,varid,'MAP_PROJ',tmp) -! maptype=int(tmp) -! status=nf_close(ncid) - -! dxval=30000. -! dyval=30000. -! -! write(6,*) 'dxval= ', dxval -! write(6,*) 'dyval= ', dyval -! write(6,*) 'cenlat= ', cenlat -! write(6,*) 'cenlon= ', cenlon -! write(6,*) 'truelat1= ', truelat1 -! write(6,*) 'truelat2= ', truelat2 -! write(6,*) 'maptype is ', maptype -! - call ext_ncd_get_dom_ti_real(DataHandle,'DX',tmp, & - 1,ioutcount,istatus) - dxval=nint(tmp*1000.) ! E-grid dlamda in degree - write(6,*) 'dxval= ', dxval - - call ext_ncd_get_dom_ti_real(DataHandle,'DY',tmp, & - 1,ioutcount,istatus) - dyval=nint(tmp*1000.) - write(6,*) 'dyval= ', dyval - - call ext_ncd_get_dom_ti_real(DataHandle,'CEN_LAT',tmp, & - 1,ioutcount,istatus) - cenlat=nint(tmp*1000.) ! E-grid dlamda in degree - write(6,*) 'cenlat= ', cenlat - - call ext_ncd_get_dom_ti_real(DataHandle,'CEN_LON',tmp, & - 1,ioutcount,istatus) - cenlon=nint(tmp*1000.) ! E-grid dlamda in degree - write(6,*) 'cenlon= ', cenlon - -! JW call ext_ncd_get_dom_ti_real(DataHandle,'TRUELAT1',tmp -! JW + ,1,ioutcount,istatus) -! JW truelat1=nint(1000.*tmp) -! JW write(6,*) 'truelat1= ', truelat1 -! JW call ext_ncd_get_dom_ti_real(DataHandle,'TRUELAT2',tmp -! JW + ,1,ioutcount,istatus) -! JW truelat2=nint(1000.*tmp) -! JW write(6,*) 'truelat2= ', truelat2 - call ext_ncd_get_dom_ti_integer(DataHandle,'MAP_PROJ',itmp, & - 1,ioutcount,istatus) - maptype=itmp - gridtype = 'E' - write(6,*) 'maptype, gridtype ', maptype, gridtype - gridtype='E' - - call ext_ncd_get_dom_ti_integer(DataHandle,'I_PARENT_START',itmp, & - 1,ioutcount,istatus) - i_parent_start=itmp - - call ext_ncd_get_dom_ti_integer(DataHandle,'J_PARENT_START',itmp, & - 1,ioutcount,istatus) - j_parent_start=itmp - - do j = jsta_2l, jend_2u - do i = 1, im -! DX ( i, j ) = dxval - DY ( i, j ) = dyval*DTR*ERAD*0.001 - end do - end do - -! generate look up table for lifted parcel calculations - - THL=210. - PLQ=70000. - - CALL TABLE(PTBL,TTBL,PT, & - RDQ,RDTH,RDP,RDTHE,PL,THL,QS0,SQS,STHE,THE0) - - CALL TABLEQ(TTBLQ,RDPQ,RDTHEQ,PLQ,THL,STHEQ,THE0Q) - -! -! - IF(ME==0)THEN - WRITE(6,*)' SPL (POSTED PRESSURE LEVELS) BELOW: ' - WRITE(6,51) (SPL(L),L=1,LSM) - 50 FORMAT(14(F4.1,1X)) - 51 FORMAT(8(F8.1,1X)) - ENDIF -! -! COMPUTE DERIVED TIME STEPPING CONSTANTS. -! - call ext_ncd_get_dom_ti_real(DataHandle,'DT',tmp, & - 1,ioutcount,istatus) - DT=tmp - print*,'DT= ',DT - DTQ2 = DT * NPHS - TSPH = 3600./DT - - TSRFC=float(NSRFC)/TSPH - IF(NSRFC==0)TSRFC=float(ifhr) !in case buket does not get emptied - TRDLW=float(NRDLW)/TSPH - IF(NRDLW==0)TRDLW=float(ifhr) !in case buket does not get emptied - TRDSW=float(NRDSW)/TSPH - IF(NRDSW==0)TRDSW=float(ifhr) !in case buket does not get emptied - THEAT=float(NHEAT)/TSPH - IF(NHEAT==0)THEAT=float(ifhr) !in case buket does not get emptied - TCLOD=float(NCLOD)/TSPH - IF(NCLOD==0)TCLOD=float(ifhr) !in case buket does not get emptied - TPREC=float(NPREC)/TSPH - IF(NPREC==0)TPREC=float(ifhr) !in case buket does not get emptied - print*,'TSRFC TRDLW TRDSW= ',TSRFC, TRDLW, TRDSW - -!how am i going to get this information? -! 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) -!how am i going to get this information? -! -! IF(ME==0)THEN -! WRITE(6,*)' ' -! WRITE(6,*)'DERIVED TIME STEPPING CONSTANTS' -! WRITE(6,*)' NPREC,NHEAT,NSRFC : ',NPREC,NHEAT,NSRFC -! WRITE(6,*)' NCLOD,NRDSW,NRDLW : ',NCLOD,NRDSW,NRDLW -! ENDIF -! -! COMPUTE DERIVED MAP OUTPUT CONSTANTS. - DO L = 1,LSM - ALSL(L) = ALOG(SPL(L)) - END DO -! - if(submodelname == 'NEST') then - print *,'NMM NEST mode: use projection center as projection center' - elseif(submodelname == 'MOAD') then - print *,'NMM MOAD mode: use domain center as projection center' - CENLAT=NINT(DCENLAT*1000) - CENLON=NINT(DCENLON*1000) - elseif(i_parent_start>1 .or. j_parent_start>1) then - print *,'No submodel specified for nested domain. Using projection center as projection center.' - else - print *,'No submodel specified for MOAD. Using domain center as projection center' - endif - - - if(me==0)then - ! write out copygb_gridnav.txt - ! provided by R.Rozumalski - NWS - - inav=10 - - TRUELAT1 = CENLAT - TRUELAT2 = CENLAT - - IFDX = NINT (dxval*107.) - IFDY = NINT (dyval*110.) - - open(inav,file='copygb_gridnav.txt',form='formatted', & - status='unknown') - - print *, ' MAPTYPE :',maptype - print *, ' IM :',IM*2-1 - print *, ' JM :',JM - print *, ' LATSTART :',LATSTART - print *, ' LONSTART :',LONSTART - print *, ' CENLAT :',CENLAT - print *, ' CENLON :',CENLON - print *, ' TRUELAT2 :',TRUELAT2 - print *, ' TRUELAT1 :',TRUELAT1 - print *, ' DX :',IFDX*0.001 - print *, ' DY :',IFDY*0.001 - - IF(MAPTYPE==0 .OR. MAPTYPE==203)THEN !A STAGGERED E-GRID - - IMM = 2*IM-1 - IDXAVE = ( IFDY + IFDX ) * 0.5 - - ! If the Center Latitude of the domain is located within 15 degrees - ! of the equator then use a a regular Lat/Lon navigation for the - ! remapped grid in copygb; otherwise, use a Lambert conformal. Make - ! sure to specify the correct pole for the S. Hemisphere (LCC). - ! - IF ( abs(CENLAT)>15000) THEN - write(6,*)' Copygb LCC Navigation Information' - IF (CENLAT >0) THEN ! Northern Hemisphere - write(6,1000) IMM,JM,LATSTART,LONSTART,CENLON, & - IFDX,IFDY,CENLAT,CENLAT - write(inav,1000) IMM,JM,LATSTART,LONSTART,CENLON, & - IFDX,IFDY,CENLAT,CENLAT - ELSE ! Southern Hemisphere - write(6,1001) IMM,JM,LATSTART,LONSTART,CENLON, & - IFDX,IFDY,CENLAT,CENLAT - write(inav,1001) IMM,JM,LATSTART,LONSTART,CENLON, & - IFDX,IFDY,CENLAT,CENLAT - END IF - ELSE - dlat = (latnm-latsm)/(JM-1) - nlat = INT (dlat) - - if (lonem < 0) lonem = 360000. + lonem - if (lonwm < 0) lonwm = 360000. + lonwm - - dlon = lonem-lonwm - if (dlon < 0.) dlon = dlon + 360000. - dlon = (dlon)/(IMM-1) - nlon = INT (dlon) - - write(6,*)' Copygb Lat/Lon Navigation Information' - write(6,2000) IMM,JM,latsm,lonwm,latnm,lonem,nlon,nlat - write(inav,2000) IMM,JM,latsm,lonwm,latnm,lonem,nlon,nlat - ENDIF - close(inav) - - 1000 format('255 3 ',2(I3,x),I6,x,I7,x,'8 ',I7,x,2(I6,x),'0 64', & - 2(x,I6)) - 1001 format('255 3 ',2(I3,x),I6,x,I7,x,'8 ',I7,x,2(I6,x),'128 64', & - 2(x,I6),' -90000 0') - 2000 format('255 0 ',2(I3,x),2(I7,x),'8 ',2(I7,x),2(I7,x),'64') - END IF ! maptype - - !HC WRITE IGDS OUT FOR WEIGHTMAKER TO READ IN AS KGDSIN - igdout=110 - if (maptype == 1)THEN ! Lambert conformal - WRITE(igdout)3 - WRITE(6,*)'igd(1)=',3 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)8 - WRITE(igdout)CENLON - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)0 - WRITE(igdout)64 -! JW WRITE(igdout)TRUELAT2 -! JW WRITE(igdout)TRUELAT1 - WRITE(igdout)255 - ELSE IF(MAPTYPE == 2)THEN !Polar stereographic - WRITE(igdout)5 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)8 - WRITE(igdout)CENLON - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)0 - WRITE(igdout)64 -! JW WRITE(igdout)TRUELAT2 !Assume projection at +-90 -! JW WRITE(igdout)TRUELAT1 - WRITE(igdout)255 - ! Note: The calculation of the map scale factor at the standard - ! lat/lon and the PSMAPF - ! Get map factor at 60 degrees (N or S) for PS projection, which will - ! be needed to correctly define the DX and DY values in the GRIB GDS - if (TRUELAT1 < 0.) THEN - LAT = -60. - else - LAT = 60. - end if - - CALL MSFPS (LAT,TRUELAT1*0.001,PSMAPF) - - ELSE IF(MAPTYPE == 3)THEN !Mercator - WRITE(igdout)1 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)8 - WRITE(igdout)latlast - WRITE(igdout)lonlast -! JW WRITE(igdout)TRUELAT1 - WRITE(igdout)0 - WRITE(igdout)64 - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)255 - ELSE IF(MAPTYPE==0 .OR. MAPTYPE==203)THEN !A STAGGERED E-GRID - WRITE(igdout)203 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)136 - WRITE(igdout)CENLAT - WRITE(igdout)CENLON - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)64 - WRITE(igdout)0 - WRITE(igdout)0 - WRITE(igdout)0 - -! following for hurricane wrf post - open(inav,file='copygb_hwrf.txt',form='formatted', & - status='unknown') - LATEND=LATSTART+(JM-1)*dyval - LONEND=LONSTART+(IMM-1)*dxval - write(10,1010) IMM,JM,LATSTART,LONSTART,LATEND,LONEND, & - dxval,dyval - -1010 format('255 0 ',2(I3,x),I6,x,I7,x,'136 ',I6,x,I7,x, & - 2(I6,x),'64') - close (inav) - - END IF - end if -! -! -! close up shop - call ext_ncd_ioclose ( DataHandle, Status ) - - RETURN - END From 91c67b71d3618dbd5d6dbb0a100addc482329798 Mon Sep 17 00:00:00 2001 From: Wen Meng Date: Sun, 16 Jan 2022 14:56:08 +0000 Subject: [PATCH 6/8] Clean up legacy makefile --- sorc/ncep_post.fd/build_upp_lib.sh | 54 ----------- sorc/ncep_post.fd/makefile_lib | 146 ----------------------------- sorc/ncep_post.fd/makefile_module | 126 ------------------------- 3 files changed, 326 deletions(-) delete mode 100755 sorc/ncep_post.fd/build_upp_lib.sh delete mode 100644 sorc/ncep_post.fd/makefile_lib delete mode 100644 sorc/ncep_post.fd/makefile_module diff --git a/sorc/ncep_post.fd/build_upp_lib.sh b/sorc/ncep_post.fd/build_upp_lib.sh deleted file mode 100755 index b3a01dae3..000000000 --- a/sorc/ncep_post.fd/build_upp_lib.sh +++ /dev/null @@ -1,54 +0,0 @@ -SHELL=/bin/sh - -module purge -set -x -mac=$(hostname | cut -c1-1) -mac2=$(hostname | cut -c1-2) - -if [ $mac2 = hf ] ; then # For Hera - machine=hera - . /etc/profile - . /etc/profile.d/modules.sh -elif [ $mac = f ] ; then # For Jet - machine=jet - . /etc/profile - . /etc/profile.d/modules.sh -elif [ $mac = v -o $mac = m ] ; then # For Dell - machine=wcoss_dell_p3 - . $MODULESHOME/init/bash -elif [ $mac = t -o $mac = e -o $mac = g ] ; then # For WCOSS - machine=wcoss - . /usrx/local/Modules/default/init/bash -elif [ $mac2 = s4 ] ; then # For S4 - machine=s4 - . /etc/profile -elif [ $mac = l -o $mac = s ] ; then # wcoss_c (i.e. luna and surge) - export machine=cray-intel -elif [ $mac = O ] ; then # For Orion - machine=orion - . /etc/profile -fi -export version=${1:-"v8.0.0"} - -moduledir=`dirname $(readlink -f ../../modulefiles/post)` -module use -a ${moduledir} -module load upp/lib-${machine} -#module load nceppost_modulefile - -# -module list - -#sleep 1 - -BASE=`pwd` - -##################################### -cd ${BASE} -rm *.o *.mod incmod -#mkdir -m 775 -p $BASE/../../lib/include/ncep_post_${version}_4 -make -f makefile_lib clean -mkdir -m 775 -p include/upp_4 -make -f makefile_lib - -exit 0 - diff --git a/sorc/ncep_post.fd/makefile_lib b/sorc/ncep_post.fd/makefile_lib deleted file mode 100644 index 37d48af6e..000000000 --- a/sorc/ncep_post.fd/makefile_lib +++ /dev/null @@ -1,146 +0,0 @@ -################################################################################ -# -# Makefile for upp (NCEP Post) -# -# Use: -# make - build the executable -# make clean - start with a clean slate -# -# The following macros will be of interest: -# -# TARGET - name of the executable -# FC - name of Fortran compiler -# CPP - name of CPP -# ARCH - architecture -# CPPFLAGS - CPP flags -# OPTS - compiler code optimizations -# LIST - source listing -# SMP - threading -# TRAPS - runtime traps for floating point exceptions -# PROFILE - source code profiling ( -pg ) -# DEBUG - -g -# MEM - user data area and stack size -# MAP - load map -# W3LIB - w3lib -# BACIO - bacio lib -# ESSL - ESSL library -# MASS - MASS library -# HPMLIB - hpm lib -# SEARCH - library search location -# -# This version for eta_post with more intelligent memory allocation -# Jim Tuccillo Feb 2001 -# -# This version for eta_post with asynchronous I/O server. -# Jim Tuccillo June 2001 - -# This version for NEMS_POST -# Jun Wang June 2010 -# -# This version for GFS V16 in-line post -# Wen Meng Ocotomber 2020 -# -################################################################################# -# -# Define the name of the executable -# - #POSTLIBPATH=../.. - #TARGET = ${POSTLIBPATH}/lib/libncep_post_${version}_4.a - #INCMOD= ${POSTLIBPATH}/lib/include/ncep_post_${version}_4 - TARGET = libupp_4.a - INCMOD = include/upp_4 - AR = ar - ARFLAGS = -rv - -# -# CPP, Compiler, and Linker Options -# - -#FC = mpfort -compiler ifort -#CPP = /lib/cpp -P -FC = $(myFC) $(myFCFLAGS) -CPP = $(myCPP) $(myCPPFLAGS) -ARCH = auto -CPPFLAGS = -DLINUX -OPTS = -O -fp-model strict -LIST = -FREE = -FR -#TRAPS = -qflttrap=ov:und:zero:inv:inex -qcheck -qinitauto=FF -TRAPS = -PROFILE = -DEBUG = -g -CFLAGS = -DLINUX -Dfunder -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -W3LIBDIR = /nwprod/lib - -SEARCH = -# -# Assemble Options -# -#FFLAGS = $(OPTS) $(FREE) $(TRAPS) $(DEBUG) -I$(CRTM_INC) -I$(W3EMC_INC4) -I$(G2_INC4) -I$(G2TMPL_INC) -I$(XMLPARSE_INC) -I$(SIGIO_INC4) -I$(GFSIO_INC4) -FFLAGS = $(OPTS) $(FREE) $(TRAPS) $(DEBUG) -I$(CRTM_INC) -I$(W3EMC_INC4) -I$(G2_INC4) -I$(G2TMPL_INC) -I$(SIGIO_INC4) -I$(GFSIO_INC4) -FFLAGST = $(OPTS) $(FREE) $(TRAPS) $(DEBUG) -I$(CRTM_INC) -I$(W3EMC_INC4) -I$(SIGIO_INC4) -I$(GFSIO_INC4) - -# -# Threaded object files -# -OBJST= kinds_mod.o machine.o physcons.o ZENSUN.o CLDFRAC_ZHAO.o GFSPOST.o -# -# Non-threaded object files -# -#OBJXML= post_t.o -# -OBJS= VRBLS2D_mod.o VRBLS3D_mod.o VRBLS4D_mod.o MASKS_mod.o PMICRPH.o SOIL_mod.o \ - CMASSI.o CTLBLK.o GRIDSPEC.o LOOKUP.o PARAMR.o RHGRD.o RQSTFLD.o xml_perl_data.o \ - cuparm.o params.o svptbl.o get_postfilename.o grib2_module.o \ - SET_LVLSXML.o FILL_PSETFLD.o \ - BNDLYR.o BOUND.o CALCAPE.o CALDWP.o CALDRG.o CALHEL.o CALLCL.o \ - CALMCVG.o CALPOT.o CALPW.o CALRH.o CALRCH.o CALRH_GSD.o \ - CALSTRM.o CALTAU.o CALTHTE.o CALVIS.o CALVIS_GSD.o CALVOR.o CALWXT.o \ - CALWXT_RAMER.o CALWXT_BOURG.o CALWXT_REVISED.o CALRH_PW.o \ - CALWXT_EXPLICIT.o CALWXT_DOMINANT.o \ - CLDRAD.o CLMAX.o COLLECT.o COLLECT_LOC.o DEWPOINT.o \ - FDLVL.o FGAMMA.o FIXED.o FRZLVL.o FRZLVL2.o \ - GET_BITS.o LFMFLD.o \ - MAPSSLP.o MISCLN.o MDL2STD_P.o MIXLEN.o MDL2P.o MDLFLD.o \ - NGMFLD.o NGMSLP.o OTLFT.o OTLIFT.o SLP_new.o SLP_NMM.o EXCH.o \ - PARA_RANGE.o PROCESS.o EXCH2.o \ - READCNTRL.o READ_xml.o SET_OUTFLDS.o SCLFLD.o \ - SMOOTH.o SURFCE.o \ - SPLINE.o TABLE.o TABLEQ.o TRPAUS.o TTBLEX.o WETBULB.o \ - CALMICT.o MICROINIT.o GPVS.o MDL2SIGMA.o \ - ETCALC.o CANRES.o CALGUST.o WETFRZLVL.o SNFRAC.o MDL2AGL.o SNFRAC_GFS.o \ - AVIATION.o DEALLOCATE.o \ - CALPBL.o MDL2SIGMA2.o CALRH_GFS.o LFMFLD_GFS.o \ - CALRAD_WCLOUD_newcrtm.o MDL2THANDPV.o CALPBLREGIME.o POLEAVG.o \ - ICAOHEIGHT.o \ - GEO_ZENITH_ANGLE.o GFIP3.o GRIDAVG.o CALUPDHEL.o \ - AllGETHERV_GSD.o MSFPS.o SELECT_CHANNELS.o ALLOCATE_ALL.o \ - gtg_ctlblk.o gtg_indices.o gtg_filter.o gtg_compute.o gtg_config.o map_routines.o gtg_algo.o gtg_smoothseams.o CALVESSEL.o \ - CALHEL2.o CALCAPE2.o - - -.SUFFIXES: .F .f .o .f90 .c - -.F.f: - $(CPP) $(CPPFLAGS) $< > $*.f - -$(TARGET): $(OBJST) $(OBJXML) $(OBJS) - $(AR) $(ARFLAGS) $@ $(OBJST) $(OBJXML) $(OBJS) $(LIBS) - mv *.mod $(INCMOD) - -.f.o: - $(FC) $(FFLAGS) -c $< - -.f90.o: - $(FC) $(FFLAGS) -c $< - -.c.o : - ${CC} ${CFLAGS} -c $< - -clean: - /bin/rm -rf libupp_*.a *.lst *.o include -# -#postcntrl_t.o : postcntrl_t.f90 -# $(FC) $(FFLAGS) postcntrl_t.f90 - - diff --git a/sorc/ncep_post.fd/makefile_module b/sorc/ncep_post.fd/makefile_module deleted file mode 100644 index 5b6f2c763..000000000 --- a/sorc/ncep_post.fd/makefile_module +++ /dev/null @@ -1,126 +0,0 @@ -################################################################################################### -# post implement module load standard -# -# 10/15 Lin Gan: Create module load version -# 12/07 Lin Gan: Update to generate post module output -# 07/16 J. Carley: Generalize for multiple machines -# -################################################################################################### - -SHELL=/bin/bash -# -# Define the name of the executable -# -# To generate exe as ncep_post -TARGET = ncep_post -LIB_TARGET = libnceppost.a -AR = ar -ARFLAGS = ruv - -# -# CPP, Compiler, and Linker Options -# - -FC = $(myFC) $(myFCFLAGS) -CPP = $(myCPP) $(myCPPFLAGS) -CPPFLAGS = -DLINUX -FREE = -FR - -NETCDF_INC = -I$(NETCDF)/include -#NETCDF_LDFLAGS = -L$(NETCDF)/lib -lnetcdff -lnetcdf -NETCDF_LDFLAGS = -L$(NETCDF)/lib -lnetcdff -lnetcdf -L$(HDF5_LDFLAGS) $(Z_LIB) - -CFLAGS = -DLINUX -Dfunder -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' - -FFLAGS = $(OPTS) $(FREE) $(DEBUG) \ - -I$(SFCIO_INC4) \ - -I$(NEMSIO_INC) \ - -I$(SIGIO_INC4) \ - -I$(G2_INC4) \ - -I$(G2TMPL_INC) \ - -I$(GFSIO_INC4) \ - -I$(W3EMC_INC4) \ - -I$(CRTM_INC) \ - -I$(IP_INC4) \ - $(NETCDF_INC) - -LIBS = $(WRFIO_LIB) \ - $(G2TMPL_LIB) \ - $(G2_LIB4) \ - $(JASPER_LIB) \ - $(PNG_LIB) \ - $(Z_LIB) \ - $(NEMSIO_LIB) \ - $(GFSIO_LIB4) \ - $(SIGIO_LIB4) \ - $(SFCIO_LIB4) \ - $(IP_LIB4) \ - $(SP_LIB4) \ - $(W3EMC_LIB4) \ - $(W3NCO_LIB4) \ - $(BACIO_LIB4) \ - $(CRTM_LIB) \ - $(NETCDF_LDFLAGS) - - -OBJS = wrf_io_flags.o getVariable.o getIVariableN.o \ - kinds_mod.o machine.o physcons.o \ - native_endianness.o blockIO.o \ - retrieve_index.o ZENSUN.o CLDFRAC_ZHAO.o \ - GFSPOST.o GFSPOSTSIG.o GETGBANDSCATTER.o \ - VRBLS2D_mod.o VRBLS3D_mod.o VRBLS4D_mod.o MASKS_mod.o PMICRPH.o SOIL_mod.o \ - CMASSI.o CTLBLK.o GRIDSPEC.o LOOKUP.o PARAMR.o RHGRD.o RQSTFLD.o xml_perl_data.o \ - cuparm.o params.o svptbl.o get_postfilename.o grib2_module.o \ - SET_LVLSXML.o FILL_PSETFLD.o \ - UPP_MATH.o UPP_PHYSICS.o \ - BNDLYR.o BOUND.o CALDWP.o CALDRG.o CALHEL.o CALLCL.o \ - CALMCVG.o CALPOT.o CALPW.o CALRCH.o \ - CALSTRM.o CALTAU.o CALTHTE.o CALVIS.o CALVIS_GSD.o CALVOR.o CALWXT.o \ - CALWXT_RAMER.o CALWXT_BOURG.o CALWXT_REVISED.o \ - CALWXT_EXPLICIT.o CALWXT_DOMINANT.o \ - CLDRAD.o CLMAX.o COLLECT.o COLLECT_LOC.o DEWPOINT.o \ - FDLVL.o FGAMMA.o FIXED.o FRZLVL.o FRZLVL2.o \ - GET_BITS.o INITPOST.o LFMFLD.o \ - MAPSSLP.o MISCLN.o MDL2STD_P.o MIXLEN.o MDL2P.o MDLFLD.o MPI_FIRST.o MPI_LAST.o \ - NGMFLD.o NGMSLP.o OTLFT.o OTLIFT.o SLP_new.o SLP_NMM.o EXCH.o \ - PARA_RANGE.o PROCESS.o INITPOST_NMM.o EXCH2.o \ - READCNTRL.o READ_xml.o SET_OUTFLDS.o SCLFLD.o SERVER.o SETUP_SERVERS.o \ - SMOOTH.o SURFCE.o \ - SPLINE.o TABLE.o TABLEQ.o TRPAUS.o TTBLEX.o WETBULB.o WRFPOST.o \ - CALMICT.o MICROINIT.o GPVS.o MDL2SIGMA.o \ - ETCALC.o CANRES.o CALGUST.o WETFRZLVL.o SNFRAC.o MDL2AGL.o SNFRAC_GFS.o \ - AVIATION.o DEALLOCATE.o \ - CALPBL.o MDL2SIGMA2.o INITPOST_GFS.o LFMFLD_GFS.o \ - CALRAD_WCLOUD_newcrtm.o MDL2THANDPV.o CALPBLREGIME.o POLEAVG.o \ - INITPOST_NEMS.o GETNEMSNDSCATTER.o ICAOHEIGHT.o INITPOST_GFS_NEMS.o \ - GEO_ZENITH_ANGLE.o GFIP3.o CALUPDHEL.o INITPOST_GFS_SIGIO.o \ - AllGETHERV_GSD.o MSFPS.o SELECT_CHANNELS.o ALLOCATE_ALL.o INITPOST_NEMS_MPIIO.o ASSIGNNEMSIOVAR.o \ - INITPOST_GFS_NEMS_MPIIO.o INITPOST_NETCDF.o INITPOST_GFS_NETCDF.o INITPOST_GFS_NETCDF_PARA.o \ - gtg_ctlblk.o gtg_indices.o gtg_filter.o gtg_compute.o gtg_config.o map_routines.o gtg_algo.o gtg_smoothseams.o CALVESSEL.o \ - CALHEL2.o ETAMP_Q2F.o - - -.SUFFIXES: .F .f .o .f90 .c - -.F.f: - $(CPP) $(CPPFLAGS) $< > $*.f - -$(TARGET): $(OBJST) $(OBJS) - $(FC) -o $@ $(OBJST) $(OBJS) $(LIBS) $(OPENMP) - mkdir -p include/post_4 - $(AR) $(ARFLAGS) $(LIB_TARGET) $(OBJST) $(OBJS) - mv *.mod include/post_4 - -.f.o: - $(FC) $(FFLAGS) -c $< - -.f90.o: - $(FC) $(FFLAGS) -c $< - -.c.o : - ${CC} ${CFLAGS} -c $< - - -clean: - /bin/rm -f *.o *.mod libnceppost.a ncep_post - /bin/rm -rf include From b31265186f55cf13597dcfc8a50f0952f77eead7 Mon Sep 17 00:00:00 2001 From: Wen Meng Date: Sun, 16 Jan 2022 15:46:50 +0000 Subject: [PATCH 7/8] Clean up another two makefiles --- sorc/ncep_post.fd/makefile | 258 --------------------------------- sorc/ncep_post.fd/makefile_dtc | 130 ----------------- 2 files changed, 388 deletions(-) delete mode 100644 sorc/ncep_post.fd/makefile delete mode 100644 sorc/ncep_post.fd/makefile_dtc diff --git a/sorc/ncep_post.fd/makefile b/sorc/ncep_post.fd/makefile deleted file mode 100644 index 7a0a614d8..000000000 --- a/sorc/ncep_post.fd/makefile +++ /dev/null @@ -1,258 +0,0 @@ -#!/bin/ksh -set -x -mac=$(hostname | cut -c1-1) -mac2=$(hostname | cut -c1-2) -################################# options ############################################### -#export CLEAN=NO # comment this line to clean before compiling -#debug=YES # turn on debug mode - default - NO - make_post_lib=YES # create post library - default - NO - make_post_exec=YES # create post executable - default - YES -#make_nowrf=YES # compile with wrf stub instead of WRF lib -################################# options ############################################### -# -if [ $mac2 = ga ] ; then # For GAEA - machine=gaea - center=${center:-ncep} - make_nowrf=${make_nowrf:-YES} # to compile with wrf stub instead of WRF lib -elif [ $mac2 = tf ] ; then # For Theia - machine=theia - make_nowrf=${make_nowrf:-YES} # to compile with wrf stub instead of WRF lib -elif [ $mac = z -o $mac = h -o $mac = f ] ; then # For ZEUS - machine=zeus - make_nowrf=${make_nowrf:-YES} # to compile with wrf stub instead of WRF lib -elif [ $mac = t -o $mac = e -o $mac = g ] ; then # For WCOSS - machine=wcoss -elif [ $mac = l -o $mac = s ] ; then # wcoss_c (i.e. luna and surge) - export machine=wcoss_c - make_nowrf=${make_nowrf:-YES} # to compile with wrf stub instead of WRF lib -fi -debug=${debug:-NO} -export make_post_lib=${make_post_lib:-NO} -export make_post_exec=${make_post_exec:-YES} -export make_nowrf=${make_nowrf:- NO} -if [ $machine = wcoss ] ; then - export NETCDFPATH="/usrx/local/NetCDF/3.6.3" - export WRFPATH="/nwprod/sorc/wrf_shared.v1.1.0" - export NWPROD="/nwprod" - export XMLPATH=$NWPROD - export IPPATH=$NWPROD - export SPPATH=/usrx/local/nceplibs - export BACIOPATH=/usrx/local/nceplibs - export ipv="" - export spv=_v2.0.2p - export crtmv=2.0.6 - export crtmv_inc=$crtmv - export xmlv=_v2.0.0 - export baciov=_v2.0.1p - export FC=mpiifort - export CPP="/lib/cpp -P" - export CPPFLAGS="-DLINUX" - export CC=cc - if [ $debug = YES ] ; then - export OPTS="-O0 -openmp " - export DEBUG="-g -traceback -convert big_endian -ftrapuv -check bounds -check format -check output_conversion -check pointers -check uninit -fp-stack-check" - else - export OPTS="-O3 -convert big_endian -fp-model source -openmp -xAVX" - export DEBUG="" - fi - export LIST="" - export FREE="-FR" - export TRAPS="" - export PROFILE="" -elif [ $machine = wcoss_c ] ; then - export FC=ftn - export CPP="/lib/cpp -P" - export CPPFLAGS="-DLINUX" - export CC=cc - if [ $debug = YES ] ; then - export OPTS="-O0 -openmp " - export DEBUG="-g -traceback -convert big_endian -ftrapuv -check bounds -check format -check output_conversion -check pointers -check uninit -fp-stack-check" - else - export OPTS="-O3 -convert big_endian -fp-model source -openmp -xAVX" - export DEBUG="" - fi - export LIST="" - export FREE="-FR" - export TRAPS="" - export PROFILE="" -elif [ $machine = zeus ] ; then - export NETCDFPATH="/apps/netcdf/3.6.3/intel" - export WRFPATH="/scratch2/portfolios/NCEPDEV/meso/save/Dusan.Jovic/WRFV3" - export NWPROD="/contrib/nceplibs/nwprod" - export XMLPATH="/home/Hui-Ya.Chuang" - export IPPATH=$NWPROD - export SPPATH=$NWPROD - export ipv="" - export spv=_v2.0.1 - export crtmv=2.0.7 - export FC="ifort -lmpi" - export CPP="/lib/cpp -P" - export CC=cc - export ARCH="" - export CPPFLAGS="-DLINUX" - if [ $debug = YES ] ; then - export OPTS="-O0 -openmp -g" - export DEBUG="-g -check all -ftrapuv -convert big_endian -fp-stack-check -fstack-protector -heap-arrays -recursive -traceback" - else - export export OPTS="-O3 -convert big_endian -traceback -g -fp-model source -openmp" - export DEBUG="" - fi - export LIST="" - export FREE="-FR" - export TRAPS="" - export PROFILE="" -elif [ $machine = theia ] ; then - export NETCDFPATH="/apps/netcdf/4.3.0-intel" - export WRFPATH="/scratch4/NCEPDEV/global/save/Shrinivas.Moorthi/theia/nceplibs/nwprod/lib/sorc/WRFV3" - export NWPROD="/scratch4/NCEPDEV/global/save/Shrinivas.Moorthi/theia/nceplibs/nwprod" - export ipv=_v2.0.3 - export spv="" - export crtmv=2.0.7 - export gfsiov="" - export w3ev=_v2.1.0 - export w3nv="" - export xmlv=_v2.0.0 - export g2tv="" - export baciov=_v2.1.0 - export XMLPATH=$NWPROD - export IPPATH=$NWPROD - export SPPATH=$NWPROD - export BACIOPATH=$NWPROD/lib - export FC=mpiifort - export CPP="/lib/cpp -P" - export CC=cc - export ARCH="" - export CPPFLAGS="-DLINUX" - if [ $debug = YES ] ; then - export OPTS="-O0 -openmp -g" - export DEBUG="-g -check all -ftrapuv -convert big_endian -fp-stack-check -fstack-protector -heap-arrays -recursive -traceback" - else - export export OPTS="-O3 -convert big_endian -traceback -g -fp-model source -openmp" - export DEBUG="" - fi - export LIST="" - export FREE="-FR" - export TRAPS="" - export PROFILE="" -elif [ $machine = gaea ] ; then - export NETCDFPATH="/opt/cray/netcdf/4.3.2/INTEL/140" - export WRFPATH="/lustre/f1/unswept/ncep/Shrinivas.Moorthi/nceplibs/nwprod/lib/sorc/WRFV3" - export NWPROD="/lustre/f1/unswept/ncep/Shrinivas.Moorthi/nceplibs/nwprod" - export IPPATH=$NWPROD - export SPPATH=$NWPROD - export baciov=_v2.1.0 - export BACIOPATH=/lustre/f1/unswept/ncep/Shrinivas.Moorthi/nceplibs/nwprod/lib/sorc/bacio_fast_byteswap/bacio${baciov}_4 - export ipv="" - export spv=_v2.0.1 - export xmlv=_v2.0.0 - export FC=ftn - export CPP="/lib/cpp -P" - export ARCH="" - export CPPFLAGS="-DLINUX" - export CC=icc - if [ $debug = YES ] ; then - export OPTS="-O0 -g" - export DEBUG="-g -check all -ftrapuv -convert big_endian -fp-stack-check -fstack-protector -heap-arrays -recursive -traceback" - else - export export OPTS="-O3 -convert big_endian -traceback -g -fp-model source" - export DEBUG="" - fi - export LIST="" - export FREE=-FR - export TRAPS="" - export PROFILE="" - - export gfsiov="" - export crtmv=2.0.7 - export w3ev=_v2.1.0 - export w3nv="" -fi -export crtmv=${crtmv:-2.0.7} -export crtmv_inc=${crtmv_inc:-v$crtmv} -export XMLPATH=${XMLPATH:-$NWPROD} -export BACIOPATH=${BACIOPATH:-$NWPROD/lib} -export xmlv=${xmlv:-""} -export w3ev=${w3ev:-_v2.0.3} -export ipv=${ipv:-""} -export spv=${spv:-""} - -if [ ${CLEAN:-YES} = YES ] ; then make -f Makefile clean ; fi - -export CFLAGS="-DLINUX -Dfunder -DFortranByte=char -DFortranInt=int -DFortranLlong='long long'" -if [ $machine = wcoss_c ] ; then - - if [ $make_nowrf = YES ] ; then - WRF_INC= - WRF_LIB= - fi - NETCDF_LIB="${NETCDF}/lib/libnetcdf.a" - export FFLAGS="${OPTS} ${FREE} ${TRAPS} ${DEBUG} -I${XMLPARSE_INC} -I${G2_INC4} -I${G2TMPL_INC} -I${NEMSIO_INC} -I${SIGIO_INC4} -I${SFCIO_INC4} -I${GFSIO_INC4} -I${W3EMC_INC4} -I${CRTM_INC} -I${NETCDF_INCLUDE} -I${PNG_INC}" - - export LIBS="${WRF_LIB} ${XMLPARSE_LIB} ${G2_LIB4} ${G2TMPL_LIB} ${NEMSIO_LIB} ${GFSIO_LIB4} ${SIGIO_LIB4} ${SFCIO_LIB4} ${IP_LIB4} ${SP_LIB4} ${W3NCO_LIB4} ${W3EMC_LIB4} ${BACIO_LIB4} ${CRTM_LIB} ${NETCDF_LIB} ${PNG_LIB} ${JASPER_LIB} ${Z_LIB}" -else - SFCIO_INC="-I${NWPROD}/lib/incmod/sfcio_4" - SFCIO_LIB="${NWPROD}/lib/libsfcio_4.a" - - NEMSIO_INC="-I${NWPROD}/lib/incmod/nemsio" - NEMSIO_LIB="-L${NWPROD}/lib -lnemsio" - BACIO_LIB="-L${BACIOPATH} -lbacio${baciov}_4" - SIGIO_INC="-I${NWPROD}/lib/incmod/sigio_4" - SIGIO_LIB="${NWPROD}/lib/libsigio_4.a" - NCDLIBS="-L${NETCDFPATH} -lnetcdf" - NCDFFLAGS="-I${NETCDFPATH}" - if [ $make_nowrf = YES ] ; then - WRF_INC= - WRF_LIB= - else - WRF_INC="-I${WRFPATH}/external/io_quilt -I${WRFPATH}/frame" - WRF_LIB="${WRFPATH}/main/libwrflib.a ${WRFPATH}/frame/pack_utils.o ${WRFPATH}/frame/module_internal_header_util.o ${WRFPATH}/external/io_grib1/libio_grib1.a ${WRFPATH}/external/io_grib_share/libio_grib_share.a ${WRFPATH}/external/io_int/libwrfio_int.a ${WRFPATH}/external/io_netcdf/libwrfio_nf.a ${WRFPATH}/external/esmf_time_f90/libesmf_time.a ${WRFPATH}/external/RSL_LITE/librsl_lite.a" - fi - - G2_INC="-I${NWPROD}/lib/incmod/g2_4 -I${NWPROD}/lib/incmod/g2tmpl${g2tv}" - G2_LIB="-L${NWPROD}/lib -lg2tmpl${g2tv} -lg2_4 -ljasper -lpng -lz" - - GFSIO_INC="-I${NWPROD}/lib/incmod/gfsio${gfsiov}_4" - GFSIO_LIB="-L${NWPROD}/lib -lgfsio${gfsiov}_4" - - IP_LIB="-L${IPPATH}/lib -lip${ipv}_4" - SP_LIB="-L${SPPATH} -lsp${sp}_4" - - W3_INC="-I${NWPROD}/lib/incmod/w3emc${w3ev}_4" - W3_LIB="-L${NWPROD}/lib -lw3nco${w3nv}_4 -lw3emc${w3ev}_4" - - CRTM_INC="-I${NWPROD}/lib/incmod/crtm_${crtmv_inc}" - CRTM_LIB="-L${NWPROD}/lib -lcrtm_v${crtmv}" - XML_INC="-I${XMLPATH}/lib/incmod/xmlparse${xmlv}" - XML_LIB="-L${XMLPATH}/lib -lxmlparse${xmlv}" - - NETCDF_LIB="${NETCDFPATH}/lib/libnetcdf.a" - NETCDF_INC="-I${NETCDFPATH}/include" - - export FFLAGS="${OPTS} ${FREE} ${TRAPS} ${DEBUG} ${WRF_INC} ${XML_INC} ${G2_INC} ${NEMSIO_INC} ${GFSIO_INC} ${SIGIO_INC} ${SFCIO_INC} ${W3_INC} ${CRTM_INC} ${NETCDF_INC}" - - export LIBS="${WRF_LIB} ${XML_LIB} ${G2_LIB} ${NEMSIO_LIB} ${GFSIO_LIB} ${SIGIO_LIB} ${SFCIO_LIB} ${IP_LIB} ${SP_LIB} ${W3_LIB} ${BACIO_LIB} ${CRTM_LIB} ${NETCDF_LIB}" - -fi -if [ $make_post_lib = NO ] ; then - if [ $make_post_exec = YES ] ; then - if [ $make_nowrf = YES ] ; then - _make -f Makefile_nowrf - else - make -f Makefile - fi - fi -else - if [ $make_post_exec = YES ] ; then - if [ $make_nowrf = YES ] ; then - make -f Makefile_nowrf - else - make -f Makefile - fi - fi - export POSTLIBPATH=${POSTLIBPATH:-$(pwd)} - if [ ${CLEAN:-YES} = YES ] ; then rm -rf $POSTLIBPATH/include/post_4 ; fi - mkdir -p $POSTLIBPATH/include/post_4 - make -f Makefile_lib -fi - - diff --git a/sorc/ncep_post.fd/makefile_dtc b/sorc/ncep_post.fd/makefile_dtc deleted file mode 100644 index 519c2418b..000000000 --- a/sorc/ncep_post.fd/makefile_dtc +++ /dev/null @@ -1,130 +0,0 @@ -SHELL = /bin/sh - -################################################################################ -# -# Makefile for NCEP Post -# -# Use: -# make - build the executable -# make clean - start with a clean slate -# -################################################################################# -# -# Define the name of the executable -# -TARGET = unipost.exe - -# -# build configuration determined before compile -include ../../configure.upp - -# -# directories for shared resources -LOCALINC = -I$(INCMOD) -I$(INCMOD)/crtm2 -NCDFINC = -I$(NETCDFPATH)/include -GRIB2INC = -I$(GRIB2SUPT_INC) - -LLIBDIR = -L$(LIBDIR) -UPPLIBS = -lCRTM $(SERIAL_MPI_LIB) -lxmlparse -NCEPLIBS = $(NCEPLIBLIB) $(NCEPLIB_FLAGS) $(GRIB2SUPT_LIB) -NCDFLIBS = -L$(NETCDFPATH)/lib $(NETCDFLIBS) - -LIBS = $(LLIBDIR) $(UPPLIBS) $(GRIB2LIBS) $(NCEPLIBS) $(NCDFLIBS) - -MODULES = - -# -# Compilation / Link Flag Configuration -EXTRA_CPPFLAGS = -EXTRA_FFLAGS = -c $(LOCALINC) $(NETCDFINC) $(NCDFINC) $(NCEPLIBINC) -#EXTRA_LDFLAGS = $(LIBS) -Wl,-Map=lm -EXTRA_LDFLAGS = $(LIBS) -EXTRA_CFLAGS = -Dfunder -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' - -# -# ----------- -# Threaded object files -# ----------- -OBJS_FT = wrf_io_flags.o getVariable.o \ - getIVariableN.o kinds_mod.o machine.o physcons.o \ - native_endianness.o \ - retrieve_index.o ZENSUN.o \ - CLDFRAC_ZHAO.o GFSPOST.o GFSPOSTSIG.o GETGBANDSCATTER.o \ - blockIO.o - -# ----------- -# Non-threaded object files -# ----------- -#OBJXML = post_t.o - -OBJS_F = VRBLS2D_mod.o VRBLS3D_mod.o VRBLS4D_mod.o MASKS_mod.o PMICRPH.o SOIL_mod.o CMASSI.o \ - CTLBLK.o GRIDSPEC.o \ - LOOKUP.o PARAMR.o RHGRD.o RQSTFLD.o xml_perl_data.o cuparm.o params.o svptbl.o get_postfilename.o grib2_module.o \ - SET_LVLSXML.o FILL_PSETFLD.o BNDLYR.o BOUND.o CALCAPE.o \ - CALDWP.o CALDRG.o CALHEL.o CALLCL.o CALMCVG.o CALPOT.o CALPW.o CALRH.o CALRCH.o \ - CALRH_GSD.o CALSTRM.o CALTAU.o CALTHTE.o CALVIS.o CALVIS_GSD.o CALVOR.o CALWXT.o $(LINUX_OBJ)\ - CALWXT_RAMER.o CALWXT_BOURG.o CALWXT_REVISED.o CALRH_PW.o CALWXT_EXPLICIT.o \ - CALWXT_DOMINANT.o CLDRAD.o \ - CLMAX.o COLLECT.o COLLECT_LOC.o DEWPOINT.o FDLVL.o FGAMMA.o FIXED.o FRZLVL.o FRZLVL2.o \ - GET_BITS.o INITPOST.o LFMFLD.o MAPSSLP.o MISCLN.o MDL2STD_P.o MIXLEN.o MDL2P.o ETAMP_Q2F.o \ - MDLFLD.o MPI_FIRST.o MPI_LAST.o NGMFLD.o NGMSLP.o OTLFT.o OTLIFT.o SLP_new.o SLP_NMM.o \ - EXCH.o PARA_RANGE.o PROCESS.o INITPOST_NMM.o EXCH2.o READCNTRL.o READ_xml.o \ - SET_OUTFLDS.o SCLFLD.o SERVER.o \ - SETUP_SERVERS.o SMOOTH.o SURFCE.o SPLINE.o TABLE.o TABLEQ.o TRPAUS.o TTBLEX.o WETBULB.o \ - WRFPOST.o CALMICT.o MICROINIT.o GPVS.o MDL2SIGMA.o ETCALC.o CANRES.o \ - CALGUST.o WETFRZLVL.o SNFRAC.o MDL2AGL.o SNFRAC_GFS.o AVIATION.o DEALLOCATE.o \ - CALPBL.o MDL2SIGMA2.o INITPOST_GFS.o CALRH_GFS.o LFMFLD_GFS.o \ - CALRAD_WCLOUD_newcrtm.o MDL2THANDPV.o CALPBLREGIME.o POLEAVG.o INITPOST_NEMS.o \ - GETNEMSNDSCATTER.o ICAOHEIGHT.o INITPOST_GFS_NEMS.o \ - GEO_ZENITH_ANGLE.o GFIP3.o GRIDAVG.o CALUPDHEL.o MSFPS.o INITPOST_GFS_SIGIO.o\ - AllGETHERV_GSD.o SELECT_CHANNELS.o ALLOCATE_ALL.o INITPOST_NEMS_MPIIO.o ASSIGNNEMSIOVAR.o INITPOST_GFS_NEMS_MPIIO.o \ - INITPOST_NETCDF.o INITPOST_GFS_NETCDF.o \ - gtg_ctlblk.o gtg_indices.o gtg_filter.o gtg_compute.o gtg_config.o map_routines.o gtg_algo.o CALVESSEL.o \ - CALHEL2.o CALCAPE2.o - -OBJS = $(OBJS_F) $(OBJXML) $(OBJS_FT) - -# ----------- -# Targets -# ----------- -all: $(TARGET) - -$(TARGET): $(XML_DEPS) $(OBJS) $(MODULES) - $(F90) -o $@ $(FFLAGS) $(MODULES) $(OBJS) $(LDFLAGS) $(EXTRA_LDFLAGS) - $(CP) $@ $(BINDIR) - -# This insures a dependency found in some files -- watch file order above remains -- should -# be done w/ dependencies -$(OBJS_F): $(OBJS_FT) $(OBJXML) - -# -# These files are configurable, but rarely change -clean: - @echo -e "\n<><><><> CLEAN <><><><>\n$@ in `pwd`" - $(RM) $(TARGET) $(OBJS) *.lst *.mod - $(RM) $(BINDIR)/$(TARGET) - for f in `ls -1 *.F|sed "s/.F$$/.f/"` ; do \ - $(RM) $$f ; \ - done - -distclean: clean - -.IGNORE: -.PHONY: clean - -.SUFFIXES: -.SUFFIXES: .F .f .f90 .o .c - -.F.o: - $(CPP) $(CPP_FLAGS) $(EXTRA_CPPFLAGS) $< > $*.f - $(F90) -c $(FFLAGS) $(EXTRA_FFLAGS) $*.f - -.f.o: - $(F90) -c $(FFLAGS) $(EXTRA_FFLAGS) $< - -.f90.o: - $(F90) -c $(FFLAGS) $(EXTRA_FFLAGS) $< - -.c.o: - ${CC} -c ${CFLAGS} $(EXTRA_CFLAGS) $< - From 8181587d715e0fafc2bb872fafc1c865649397cf Mon Sep 17 00:00:00 2001 From: Wen Meng Date: Tue, 18 Jan 2022 15:46:40 +0000 Subject: [PATCH 8/8] Add back INITPOST_GFS_NETCDF --- sorc/ncep_post.fd/CMakeLists.txt | 1 + sorc/ncep_post.fd/INITPOST_GFS_NETCDF.f | 2761 +++++++++++++++++++++++ 2 files changed, 2762 insertions(+) create mode 100644 sorc/ncep_post.fd/INITPOST_GFS_NETCDF.f diff --git a/sorc/ncep_post.fd/CMakeLists.txt b/sorc/ncep_post.fd/CMakeLists.txt index f2c32337e..0855a7788 100644 --- a/sorc/ncep_post.fd/CMakeLists.txt +++ b/sorc/ncep_post.fd/CMakeLists.txt @@ -151,6 +151,7 @@ list(APPEND EXE_SRC GFSPOSTSIG.F INITPOST.F INITPOST_GFS_NEMS_MPIIO.f + INITPOST_GFS_NETCDF.f INITPOST_GFS_NETCDF_PARA.f INITPOST_NEMS.f INITPOST_NETCDF.f diff --git a/sorc/ncep_post.fd/INITPOST_GFS_NETCDF.f b/sorc/ncep_post.fd/INITPOST_GFS_NETCDF.f new file mode 100644 index 000000000..b61732212 --- /dev/null +++ b/sorc/ncep_post.fd/INITPOST_GFS_NETCDF.f @@ -0,0 +1,2761 @@ +!> @file +! . . . +!> SUBPROGRAM: INITPOST_NETCDF INITIALIZE POST FOR RUN +!! PRGRMMR: Hui-Ya Chuang DATE: 2016-03-04 +!! +!! ABSTRACT: THIS ROUTINE INITIALIZES CONSTANTS AND +!! VARIABLES AT THE START OF GFS MODEL OR POST +!! PROCESSOR RUN. +!! +!! REVISION HISTORY +!! 2017-08-11 H Chuang start from INITPOST_GFS_NEMS_MPIIO.f +!! 2021-03-11 Bo Cui change local arrays to dimension (im,jsta:jend) +!! +!! USAGE: CALL INITPOST_NETCDF +!! INPUT ARGUMENT LIST: +!! NONE +!! +!! OUTPUT ARGUMENT LIST: +!! NONE +!! +!! OUTPUT FILES: +!! NONE +!! +!! SUBPROGRAMS CALLED: +!! UTILITIES: +!! NONE +!! LIBRARY: +!! COMMON - CTLBLK +!! LOOKUP +!! SOILDEPTH +!! +!! +!! ATTRIBUTES: +!! LANGUAGE: FORTRAN +!! MACHINE : CRAY C-90 +!! + SUBROUTINE INITPOST_GFS_NETCDF(ncid3d) + + + use netcdf + use vrbls4d, only: dust, SALT, SUSO, SOOT, WASO, PP25, PP10 + use vrbls3d, only: t, q, uh, vh, pmid, pint, alpint, dpres, zint, zmid, o3, & + qqr, qqs, cwm, qqi, qqw, omga, rhomid, q2, cfr, rlwtt, rswtt, tcucn, & + tcucns, train, el_pbl, exch_h, vdifftt, vdiffmois, dconvmois, nradtt, & + o3vdiff, o3prod, o3tndy, mwpv, unknown, vdiffzacce, zgdrag,cnvctummixing, & + vdiffmacce, mgdrag, cnvctvmmixing, ncnvctcfrac, cnvctumflx, cnvctdmflx, & + cnvctzgdrag, sconvmois, cnvctmgdrag, cnvctdetmflx, duwt, duem, dusd, dudp, & + wh, qqg, ref_10cm + use vrbls2d, only: f, pd, fis, pblh, ustar, z0, ths, qs, twbs, qwbs, avgcprate, & + cprate, avgprec, prec, lspa, sno, si, cldefi, th10, q10, tshltr, pshltr, & + tshltr, albase, avgalbedo, avgtcdc, czen, czmean, mxsnal, radot, sigt4, & + cfrach, cfracl, cfracm, avgcfrach, qshltr, avgcfracl, avgcfracm, cnvcfr, & + islope, cmc, grnflx, vegfrc, acfrcv, ncfrcv, acfrst, ncfrst, ssroff, & + bgroff, rlwin, rlwtoa, cldwork, alwin, alwout, alwtoa, rswin, rswinc, & + rswout, aswin, auvbin, auvbinc, aswout, aswtoa, sfcshx, sfclhx, subshx, & + snopcx, sfcux, sfcvx, sfcuxi, sfcvxi, sfcuvx, gtaux, gtauy, potevp, u10, v10, smstav, & + smstot, ivgtyp, isltyp, sfcevp, sfcexc, acsnow, acsnom, sst, thz0, qz0, & + uz0, vz0, ptop, htop, pbot, hbot, ptopl, pbotl, ttopl, ptopm, pbotm, ttopm, & + ptoph, pboth, pblcfr, ttoph, runoff, maxtshltr, mintshltr, maxrhshltr, & + minrhshltr, dzice, smcwlt, suntime, fieldcapa, htopd, hbotd, htops, hbots, & + cuppt, dusmass, ducmass, dusmass25, ducmass25, aswintoa,rel_vort_maxhy1, & + maxqshltr, minqshltr, acond, sr, u10h, v10h,refd_max, w_up_max, w_dn_max, & + up_heli_max,up_heli_min,up_heli_max03,up_heli_min03,rel_vort_max01,u10max, v10max, & + avgedir,avgecan,avgetrans,avgesnow,avgprec_cont,avgcprate_cont,rel_vort_max, & + avisbeamswin,avisdiffswin,airbeamswin,airdiffswin,refdm10c_max,wspd10max, & + alwoutc,alwtoac,aswoutc,aswtoac,alwinc,aswinc,avgpotevp,snoavg, & + ti,aod550,du_aod550,ss_aod550,su_aod550,oc_aod550,bc_aod550 + use soil, only: sldpth, sh2o, smc, stc + use masks, only: lmv, lmh, htm, vtm, gdlat, gdlon, dx, dy, hbm2, sm, sice + use physcons_post, only: grav => con_g, fv => con_fvirt, rgas => con_rd, & + eps => con_eps, epsm1 => con_epsm1 + use params_mod, only: erad, dtr, tfrz, h1, d608, rd, p1000, capa,pi + use lookup_mod, only: thl, plq, ptbl, ttbl, rdq, rdth, rdp, rdthe, pl, qs0, sqs, sthe, & + ttblq, rdpq, rdtheq, stheq, the0q, the0 + use ctlblk_mod, only: me, mpi_comm_comp, icnt, idsp, jsta, jend, ihrst, idat, sdat, ifhr, & + ifmin, filename, tprec, tclod, trdlw, trdsw, tsrfc, tmaxmin, td3d, restrt, sdat, & + jend_m, imin, imp_physics, dt, spval, pdtop, pt, qmin, nbin_du, nphs, dtq2, ardlw,& + ardsw, asrfc, avrain, avcnvc, theat, gdsdegr, spl, lsm, alsl, im, jm, im_jm, lm, & + jsta_2l, jend_2u, nsoil, lp1, icu_physics, ivegsrc, novegtype, nbin_ss, nbin_bc, & + nbin_oc, nbin_su, gocart_on, pt_tbl, hyb_sigp, filenameFlux, fileNameAER,rdaod + use gridspec_mod, only: maptype, gridtype, latstart, latlast, lonstart, lonlast, cenlon, & + dxval, dyval, truelat2, truelat1, psmapf, cenlat,lonstartv, lonlastv, cenlonv, & + latstartv, latlastv, cenlatv,latstart_r,latlast_r,lonstart_r,lonlast_r + use upp_physics, only: fpvsnew +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + implicit none +! +! type(nemsio_gfile) :: nfile,ffile,rfile + integer,parameter :: nvar2d=48 +! character(nemsio_charkind) :: name2d(nvar2d) + integer :: nvar3d, numDims +! character(nemsio_charkind), allocatable :: name3din(:), name3dout(:) +! character(nemsio_charkind) :: varname,levtype +! +! INCLUDE/SET PARAMETERS. +! + INCLUDE "mpif.h" + +! integer,parameter:: MAXPTS=1000000 ! max im*jm points +! +! real,parameter:: con_g =9.80665e+0! gravity +! real,parameter:: con_rv =4.6150e+2 ! gas constant H2O +! real,parameter:: con_rd =2.8705e+2 ! gas constant air +! real,parameter:: con_fvirt =con_rv/con_rd-1. +! real,parameter:: con_eps =con_rd/con_rv +! real,parameter:: con_epsm1 =con_rd/con_rv-1 +! +! This version of INITPOST shows how to initialize, open, read from, and +! close a NetCDF dataset. In order to change it to read an internal (binary) +! dataset, do a global replacement of _ncd_ with _int_. + + real, parameter :: gravi = 1.0/grav + character(len=20) :: VarName, VcoordName + integer :: Status, fldsize, fldst, recn, recn_vvel + character startdate*19,SysDepInfo*80,cgar*1 + character startdate2(19)*4 +! +! NOTE: SOME INTEGER VARIABLES ARE READ INTO DUMMY ( A REAL ). THIS IS OK +! AS LONG AS REALS AND INTEGERS ARE THE SAME SIZE. +! +! ALSO, EXTRACT IS CALLED WITH DUMMY ( A REAL ) EVEN WHEN THE NUMBERS ARE +! INTEGERS - THIS IS OK AS LONG AS INTEGERS AND REALS ARE THE SAME SIZE. + LOGICAL RUNB,SINGLRST,SUBPOST,NEST,HYDRO,IOOMG,IOALL +! logical, parameter :: debugprint = .true., zerout = .false. + logical, parameter :: debugprint = .false., zerout = .false. + logical :: convert_rad_to_deg=.false. + CHARACTER*32 varcharval +! CHARACTER*40 CONTRL,FILALL,FILMST,FILTMP,FILTKE,FILUNV,FILCLD,FILRAD,FILSFC + CHARACTER*4 RESTHR + CHARACTER FNAME*255,ENVAR*50 + INTEGER IDATE(8),JDATE(8),JPDS(200),JGDS(200),KPDS(200),KGDS(200) +! LOGICAL*1 LB(IM,JM) +! +! INCLUDE COMMON BLOCKS. +! +! DECLARE VARIABLES. +! +! REAL fhour +! integer nfhour ! forecast hour from nems io file + integer fhzero !bucket + real dtp !physics time step + REAL RINC(5) + +! REAL FI(IM,JM,2) + REAL DUMMY(IM,JM) + +!jw + integer ii,jj,js,je,iyear,imn,iday,itmp,ioutcount,istatus, & + I,J,L,ll,k,kf,irtn,igdout,n,Index,nframe, & + nframed2,iunitd3d,ierr,idum,iret,nrec,idrt + integer ncid3d,ncid2d,varid,nhcas + real TSTART,TLMH,TSPH,ES,FACT,soilayert,soilayerb,zhour,dum, & + tvll,pmll,tv, tx1, tx2 + + character*20,allocatable :: recname(:) + integer, allocatable :: reclev(:), kmsk(:,:) + real, allocatable :: glat1d(:), glon1d(:), qstl(:) + real, allocatable :: wrk1(:,:), wrk2(:,:) + real, allocatable :: p2d(:,:), t2d(:,:), q2d(:,:), & + qs2d(:,:), cw2d(:,:), cfr2d(:,:) + real(kind=4),allocatable :: vcoord4(:,:,:) + real, dimension(lm+1) :: ak5, bk5 + real*8, allocatable :: pm2d(:,:), pi2d(:,:) + real, allocatable :: tmp(:) + real :: buf(im,jsta_2l:jend_2u) + real :: buf3d(im,jsta_2l:jend_2u,lm) + +! real buf(im,jsta_2l:jend_2u),bufsoil(im,nsoil,jsta_2l:jend_2u) & +! ,buf3d(im,jsta_2l:jend_2u,lm),buf3d2(im,lp1,jsta_2l:jend_2u) + + real LAT + integer isa, jsa, latghf, jtem, idvc, idsl, nvcoord, ip1, nn, npass + + integer, parameter :: npass2=5, npass3=30 + real, parameter :: third=1.0/3.0 + INTEGER, DIMENSION(2) :: ij4min, ij4max + REAL :: omgmin, omgmax + real, allocatable :: d2d(:,:), u2d(:,:), v2d(:,:), omga2d(:,:) + REAL, ALLOCATABLE :: ps2d(:,:),psx2d(:,:),psy2d(:,:) + real, allocatable :: div3d(:,:,:) + real(kind=4),allocatable :: vcrd(:,:) + real :: dum_const + +!*********************************************************************** +! START INIT HERE. +! + WRITE(6,*)'INITPOST: ENTER INITPOST_GFS_NETCDF' + WRITE(6,*)'me=',me, & + 'jsta_2l=',jsta_2l,'jend_2u=', & + jend_2u,'im=',im +! + isa = im / 2 + jsa = (jsta+jend) / 2 + +!$omp parallel do private(i,j) + do j = jsta_2l, jend_2u + do i=1,im + buf(i,j) = spval + enddo + enddo + + Status=nf90_get_att(ncid3d,nf90_global,'ak',ak5) + if(Status/=0)then + print*,'ak not found; assigning missing value' + ak5=spval + else + if(me==0)print*,'ak5= ',ak5 + end if + Status=nf90_get_att(ncid3d,nf90_global,'idrt',idrt) + if(Status/=0)then + print*,'idrt not in netcdf file,reading grid' + Status=nf90_get_att(ncid3d,nf90_global,'grid',varcharval) + if(Status/=0)then + print*,'idrt and grid not in netcdf file, set default to latlon' + idrt=0 + MAPTYPE=0 + else + if(trim(varcharval)=='rotated_latlon')then + MAPTYPE=207 + idrt=207 + Status=nf90_get_att(ncid3d,nf90_global,'cen_lon',dum_const) + if(Status/=0)then + print*,'cen_lon not found; assigning missing value' + cenlon=spval + else + if(dum_const<0.)then + cenlon=nint((dum_const+360.)*gdsdegr) + else + cenlon=dum_const*gdsdegr + end if + end if + Status=nf90_get_att(ncid3d,nf90_global,'cen_lat',dum_const) + if(Status/=0)then + print*,'cen_lat not found; assigning missing value' + cenlat=spval + else + cenlat=dum_const*gdsdegr + end if + + Status=nf90_get_att(ncid3d,nf90_global,'lon1',dum_const) + if(Status/=0)then + print*,'lonstart_r not found; assigning missing value' + lonstart_r=spval + else + if(dum_const<0.)then + lonstart_r=nint((dum_const+360.)*gdsdegr) + else + lonstart_r=dum_const*gdsdegr + end if + end if + Status=nf90_get_att(ncid3d,nf90_global,'lat1',dum_const) + if(Status/=0)then + print*,'latstart_r not found; assigning missing value' + latstart_r=spval + else + latstart_r=dum_const*gdsdegr + end if + + Status=nf90_get_att(ncid3d,nf90_global,'lon2',dum_const) + if(Status/=0)then + print*,'lonlast_r not found; assigning missing value' + lonlast_r=spval + else + if(dum_const<0.)then + lonlast_r=nint((dum_const+360.)*gdsdegr) + else + lonlast_r=dum_const*gdsdegr + end if + end if + Status=nf90_get_att(ncid3d,nf90_global,'lat2',dum_const) + if(Status/=0)then + print*,'latlast_r not found; assigning missing value' + latlast_r=spval + else + latlast_r=dum_const*gdsdegr + end if + + Status=nf90_get_att(ncid3d,nf90_global,'dlon',dum_const) + if(Status/=0)then + print*,'dlmd not found; assigning missing value' + dxval=spval + else + dxval=dum_const*gdsdegr + end if + Status=nf90_get_att(ncid3d,nf90_global,'dlat',dum_const) + if(Status/=0)then + print*,'dphd not found; assigning missing value' + dyval=spval + else + dyval=dum_const*gdsdegr + end if + + print*,'lonstart,latstart,cenlon,cenlat,dyval,dxval', & + lonstart,latstart,cenlon,cenlat,dyval,dxval + +! Jili Dong add support for regular lat lon (2019/03/22) start + else if(trim(varcharval)=='latlon')then + MAPTYPE=0 + idrt=0 + + Status=nf90_get_att(ncid3d,nf90_global,'lon1',dum_const) + if(Status/=0)then + print*,'lonstart not found; assigning missing value' + lonstart=spval + else + if(dum_const<0.)then + lonstart=nint((dum_const+360.)*gdsdegr) + else + lonstart=dum_const*gdsdegr + end if + end if + Status=nf90_get_att(ncid3d,nf90_global,'lat1',dum_const) + if(Status/=0)then + print*,'latstart not found; assigning missing value' + latstart=spval + else + latstart=dum_const*gdsdegr + end if + + Status=nf90_get_att(ncid3d,nf90_global,'lon2',dum_const) + if(Status/=0)then + print*,'lonlast not found; assigning missing value' + lonlast=spval + else + if(dum_const<0.)then + lonlast=nint((dum_const+360.)*gdsdegr) + else + lonlast=dum_const*gdsdegr + end if + end if + Status=nf90_get_att(ncid3d,nf90_global,'lat2',dum_const) + if(Status/=0)then + print*,'latlast not found; assigning missing value' + latlast=spval + else + latlast=dum_const*gdsdegr + end if + + Status=nf90_get_att(ncid3d,nf90_global,'dlon',dum_const) + if(Status/=0)then + print*,'dlmd not found; assigning missing value' + dxval=spval + else + dxval=dum_const*gdsdegr + end if + Status=nf90_get_att(ncid3d,nf90_global,'dlat',dum_const) + if(Status/=0)then + print*,'dphd not found; assigning missing value' + dyval=spval + else + dyval=dum_const*gdsdegr + end if + + print*,'lonstart,latstart,dyval,dxval', & + lonstart,lonlast,latstart,latlast,dyval,dxval + +! Jili Dong add support for regular lat lon (2019/03/22) end + + else if(trim(varcharval)=='gaussian')then + MAPTYPE=4 + idrt=4 + else ! setting default maptype + MAPTYPE=0 + idrt=0 + end if + end if !end reading grid + end if !end reading idrt + if(me==0)print*,'idrt MAPTYPE= ',idrt,MAPTYPE +! STEP 1. READ MODEL OUTPUT FILE +! +! +!*** +! +! LMH and LMV always = LM for sigma-type vert coord + +!$omp parallel do private(i,j) + do j = jsta_2l, jend_2u + do i = 1, im + LMV(i,j) = lm + LMH(i,j) = lm + end do + end do + +! HTM VTM all 1 for sigma-type vert coord + +!$omp parallel do private(i,j,l) + do l = 1, lm + do j = jsta_2l, jend_2u + do i = 1, im + HTM (i,j,l) = 1.0 + VTM (i,j,l) = 1.0 + end do + end do + end do + + Status=nf90_get_att(ncid3d,nf90_global,'nhcas',nhcas) + if(Status/=0)then + print*,'nhcas not in netcdf file, set default to nonhydro' + nhcas=0 + end if + if(me==0)print*,'nhcas= ',nhcas + if (nhcas == 0 ) then !non-hydrostatic case + nrec=15 + allocate (recname(nrec)) + recname=[character(len=20) :: 'ugrd','vgrd','spfh','tmp','o3mr', & + 'presnh','dzdt', 'clwmr','dpres', & + 'delz','icmr','rwmr', & + 'snmr','grle','cld_amt'] + else + nrec=8 + allocate (recname(nrec)) + recname=[character(len=20) :: 'ugrd','vgrd','tmp','spfh','o3mr', & + 'hypres', 'clwmr','dpres'] + endif + +! write(0,*)'nrec=',nrec + !allocate(recname(nrec),reclevtyp(nrec),reclev(nrec)) + allocate(glat1d(jm),glon1d(im)) + allocate(vcoord4(lm+1,3,2)) + +! hardwire idate for now +! idate=(/2017,08,07,00,0,0,0,0/) +! get cycle start time + Status=nf90_inq_varid(ncid3d,'time',varid) + if(Status/=0)then + print*,'time not in netcdf file, stopping' + STOP 1 + else + Status=nf90_get_att(ncid3d,varid,'units',varcharval) + if(Status/=0)then + print*,'time unit not available' + else + print*,'time unit read from netcdf file= ',varcharval +! assume use hours as unit +! idate_loc=index(varcharval,'since')+6 + read(varcharval,101)idate(1),idate(2),idate(3),idate(4),idate(5) + end if +! Status=nf90_inquire_dimension(ncid3d,varid,len=ntimes) +! allocate(fhours(ntimes)) +! status = nf90_inq_varid(ncid3d,varid,fhours) +! Status=nf90_get_var(ncid3d,varid,nfhour,start=(/1/), & +! count=(/1/)) +! if(Status/=0)then +! print*,'forecast hour not in netcdf file, stopping' +! STOP 1 +! end if + end if + 101 format(T13,i4,1x,i2,1x,i2,1x,i2,1x,i2) + print*,'idate= ',idate(1:5) +! get longitude + Status=nf90_inq_varid(ncid3d,'grid_xt',varid) + Status=nf90_inquire_variable(ncid3d,varid,ndims = numDims) + if(debugprint)print*,'number of dim for gdlon ',numDims + if(numDims==1)then + Status=nf90_get_var(ncid3d,varid,glon1d) + do j=jsta,jend + do i=1,im + gdlon(i,j) = real(glon1d(i),kind=4) + end do + end do + lonstart = nint(glon1d(1)*gdsdegr) + lonlast = nint(glon1d(im)*gdsdegr) + dxval = nint(abs(glon1d(1)-glon1d(2))*gdsdegr) + else if(numDims==2)then + Status=nf90_get_var(ncid3d,varid,dummy) + if(maxval(abs(dummy))<2.0*pi)convert_rad_to_deg=.true. + if(convert_rad_to_deg)then + do j=jsta,jend + do i=1,im + gdlon(i,j) = real(dummy(i,j),kind=4)*180./pi + end do + end do + else + do j=jsta,jend + do i=1,im + gdlon(i,j) = real(dummy(i,j),kind=4) + end do + end do + end if + if(convert_rad_to_deg)then + lonstart = nint(dummy(1,1)*gdsdegr)*180./pi + lonlast = nint(dummy(im,jm)*gdsdegr)*180./pi + dxval = nint(abs(dummy(1,1)-dummy(2,1))*gdsdegr)*180./pi + else + lonstart = nint(dummy(1,1)*gdsdegr) + lonlast = nint(dummy(im,jm)*gdsdegr) + dxval = nint(abs(dummy(1,1)-dummy(2,1))*gdsdegr) + end if + +! Jili Dong add support for regular lat lon (2019/03/22) start + if (MAPTYPE == 0) then + if(lonstart<0.)then + lonstart=lonstart+360.*gdsdegr + end if + if(lonlast<0.)then + lonlast=lonlast+360.*gdsdegr + end if + end if +! Jili Dong add support for regular lat lon (2019/03/22) end + + end if + print*,'lonstart,lonlast,dxval ',lonstart,lonlast,dxval +! get latitude + Status=nf90_inq_varid(ncid3d,'grid_yt',varid) + Status=nf90_inquire_variable(ncid3d,varid,ndims = numDims) + if(debugprint)print*,'number of dim for gdlat ',numDims + if(numDims==1)then + Status=nf90_get_var(ncid3d,varid,glat1d) + do j=jsta,jend + do i=1,im + gdlat(i,j) = real(glat1d(j),kind=4) + end do + end do + latstart = nint(glat1d(1)*gdsdegr) + latlast = nint(glat1d(jm)*gdsdegr) + dyval = nint(abs(glat1d(1)-glat1d(2))*gdsdegr) + else if(numDims==2)then + Status=nf90_get_var(ncid3d,varid,dummy) + if(maxval(abs(dummy))1.0e5)print*,'bad dpres ',i,j,dpres(i,j,l) +!make sure delz is positive +! if(dpres(i,j,l)/=spval .and. t(i,j,l)/=spval .and. & +! q(i,j,l)/=spval .and. buf3d(i,j,l)/=spval)then +! pmid(i,j,l)=rgas*dpres(i,j,l)* & +! t(i,j,l)*(q(i,j,l)*fv+1.0)/grav/abs(buf3d(i,j,l)) +! else +! pmid(i,j,l)=spval +! end if +! dong add missing value + if (wh(i,j,l) < spval) then + omga(i,j,l)=(-1.)*wh(i,j,l)*dpres(i,j,l)/abs(buf3d(i,j,l)) + else + omga(i,j,l) = spval + end if +! if(t(i,j,l)>1000.)print*,'bad T ',t(i,j,l) + enddo + enddo + enddo + call read_netcdf_3d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,recname(11) & + ,lm,qqi(1,jsta_2l,1)) + call read_netcdf_3d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,recname(12) & + ,lm,qqr(1,jsta_2l,1)) + call read_netcdf_3d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,recname(13) & + ,lm,qqs(1,jsta_2l,1)) + call read_netcdf_3d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,recname(14) & + ,lm,qqg(1,jsta_2l,1)) + call read_netcdf_3d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,recname(15) & + ,lm,cfr(1,jsta_2l,1)) +! calculate CWM from FV3 output + do l=1,lm + do j=jsta,jend + do i=1,im + cwm(i,j,l)=qqg(i,j,l)+qqs(i,j,l)+qqr(i,j,l)+qqi(i,j,l)+qqw(i,j,l) + enddo + enddo + if(debugprint)print*,'sample l,t,q,u,v,w,= ',isa,jsa,l & + ,t(isa,jsa,l),q(isa,jsa,l),uh(isa,jsa,l),vh(isa,jsa,l) & + ,wh(isa,jsa,l) + if(debugprint)print*,'sample l cwm for FV3',l, & + cwm(isa,jsa,l) + end do +! max hourly updraft velocity +! VarName='upvvelmax' +! call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & +! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,w_up_max) +! if(debugprint)print*,'sample ',VarName,' = ',w_up_max(isa,jsa) + +! max hourly downdraft velocity +! VarName='dnvvelmax' +! call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & +! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,w_dn_max) +! if(debugprint)print*,'sample ',VarName,' = ',w_dn_max(isa,jsa) +! max hourly updraft helicity +! VarName='uhmax25' +! call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & +! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,up_heli_max) +! if(debugprint)print*,'sample ',VarName,' = ',up_heli_max(isa,jsa) +! min hourly updraft helicity +! VarName='uhmin25' +! call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & +! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,up_heli_min) +! if(debugprint)print*,'sample ',VarName,' = ',up_heli_min(isa,jsa) +! max hourly 0-3km updraft helicity +! VarName='uhmax03' +! call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & +! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,up_heli_max03) +! if(debugprint)print*,'sample ',VarName,' = ',up_heli_max03(isa,jsa) +! min hourly 0-3km updraft helicity +! VarName='uhmin03' +! call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & +! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,up_heli_min03) +! if(debugprint)print*,'sample ',VarName,' = ',up_heli_min03(isa,jsa) + +! max 0-1km relative vorticity max +! VarName='maxvort01' +! call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & +! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,rel_vort_max01) +! if(debugprint)print*,'sample ',VarName,' = ',rel_vort_max01(isa,jsa) +! max 0-2km relative vorticity max +! VarName='maxvort02' +! call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & +! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,rel_vort_max) +! if(debugprint)print*,'sample ',VarName,' =',rel_vort_max(isa,jsa) +! max hybrid lev 1 relative vorticity max +! VarName='maxvorthy1' +! call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & +! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,rel_vort_maxhy1) +! if(debugprint)print*,'sample ',VarName,' =',rel_vort_maxhy1(isa,jsa) +! surface pressure + VarName='pressfc' + call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & + ,pint(1,jsta_2l,lp1)) + do j=jsta,jend + do i=1,im +! if(pint(i,j,lp1)>1.0E6 .or. pint(1,jsta_2l,lp1)<50000.) & +! print*,'bad psfc ',i,j,pint(i,j,lp1) + end do + end do + if(debugprint)print*,'sample ',VarName,' =',pint(isa,jsa,lp1) + + pt = ak5(1) + + do j=jsta,jend + do i=1,im + pint(i,j,1)= pt + end do + end do + + do l=2,lp1 + do j=jsta,jend + do i=1,im + pint(i,j,l) = pint(i,j,l-1) + dpres(i,j,l-1) + enddo + enddo +! if (me == 0) print*,'sample model pint,pmid' ,ii,jj,l & +! ,pint(ii,jj,l),pmid(ii,jj,l) + end do + +!compute pmid from averaged two layer pint + do l=lm,1,-1 + do j=jsta,jend + do i=1,im + pmid(i,j,l) = 0.5*(pint(i,j,l)+pint(i,j,l+1)) + enddo + enddo + enddo + +! do l=lm,1,-1 +! do j=jsta,jend +! do i=1,im +! if(pint(i,j,l+1)/=spval .and. dpres(i,j,l)/=spval)then +! pint(i,j,l)=pint(i,j,l+1)-dpres(i,j,l) +! else +! pint(i,j,l)=spval +! end if +! end do +! end do +! print*,'sample pint= ',isa,jsa,l,pint(isa,jsa,l) +! end do + +! surface height from FV3 +! dong set missing value for zint +! zint=spval + VarName='hgtsfc' + call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & + ,zint(1,jsta_2l,lp1)) + if(debugprint)print*,'sample ',VarName,' =',zint(isa,jsa,lp1) + do j=jsta,jend + do i=1,im + if (zint(i,j,lp1) /= spval) then + fis(i,j) = zint(i,j,lp1) * grav + else + fis(i,j) = spval + endif + enddo + enddo + + do l=lm,1,-1 + do j=jsta,jend + do i=1,im + if(zint(i,j,l+1)/=spval .and. buf3d(i,j,l)/=spval)then +!make sure delz is positive + zint(i,j,l)=zint(i,j,l+1)+abs(buf3d(i,j,l)) +! if(zint(i,j,l)>1.0E6)print*,'bad H ',i,j,l,zint(i,j,l) + else + zint(i,j,l)=spval + end if + end do + end do + print*,'sample zint= ',isa,jsa,l,zint(isa,jsa,l) + end do + + do l=lp1,1,-1 + do j=jsta,jend + do i=1,im + alpint(i,j,l)=log(pint(i,j,l)) + end do + end do + end do + + do l=lm,1,-1 + do j=jsta,jend + do i=1,im + if(zint(i,j,l+1)/=spval .and. zint(i,j,l)/=spval & + .and. pmid(i,j,l)/=spval)then + zmid(i,j,l)=zint(i,j,l+1)+(zint(i,j,l)-zint(i,j,l+1))* & + (log(pmid(i,j,l))-alpint(i,j,l+1))/ & + (alpint(i,j,l)-alpint(i,j,l+1)) + if(zmid(i,j,l)>1.0E6)print*,'bad Hmid ',i,j,l,zmid(i,j,l) + else + zmid(i,j,l)=spval + endif + end do + end do + end do + + + pt = ak5(1) + +! else +! do l=2,lm +!!$omp parallel do private(i,j) +! do j=jsta,jend +! do i=1,im +! pint(i,j,l) = pint(i,j,l-1) + dpres(i,j,l-1) +! enddo +! enddo +! if (me == 0) print*,'sample pint,pmid' ,ii,jj,l,pint(ii,jj,l),pmid(ii,jj,l) +! end do +! endif +! + + deallocate (vcoord4) +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +! + +! done with 3d file, close it for now + Status=nf90_close(ncid3d) + deallocate(recname) + +! open flux file + Status = nf90_open(trim(fileNameFlux),NF90_NOWRITE, ncid2d) + + if ( Status /= 0 ) then + print*,'error opening ',fileNameFlux, ' Status = ', Status + print*,'skip reading of flux file' + endif + +! IVEGSRC=1 for IGBP, 0 for USGS, 2 for UMD + VarName='IVEGSRC' + Status=nf90_get_att(ncid2d,nf90_global,'IVEGSRC',IVEGSRC) + if (Status /= 0) then + print*,VarName,' not found-Assigned 1 for IGBP as default' + IVEGSRC=1 + end if + if (me == 0) print*,'IVEGSRC= ',IVEGSRC + +! set novegtype based on vegetation classification + if(ivegsrc==2)then + novegtype=13 + else if(ivegsrc==1)then + novegtype=20 + else if(ivegsrc==0)then + novegtype=24 + end if + if (me == 0) print*,'novegtype= ',novegtype + + Status=nf90_get_att(ncid2d,nf90_global,'imp_physics',imp_physics) + if (Status /= 0) then + print*,VarName,' not found-Assigned 11 GFDL as default' + imp_physics=11 + end if + if (me == 0) print*,'MP_PHYSICS= ',imp_physics +! + Status=nf90_get_att(ncid2d,nf90_global,'fhzero',fhzero) + if (Status /= 0) then + print*,VarName,' not found-Assigned 3 hours as default' + fhzero=3 + end if + if (me == 0) print*,'fhzero= ',fhzero +! + Status=nf90_get_att(ncid2d,nf90_global,'dtp',dtp) + if (Status /= 0) then + print*,VarName,' not found-Assigned 90s as default' + dtp=90 + end if + if (me == 0) print*,'dtp= ',dtp +! Initializes constants for Ferrier microphysics + if(imp_physics==5 .or. imp_physics==85 .or. imp_physics==95) then + CALL MICROINIT(imp_physics) + end if + +! Chuang: zhour is when GFS empties bucket last so using this +! to compute buket will result in changing bucket with forecast time. +! set default bucket for now + +! call nemsio_getheadvar(ffile,'zhour',zhour,iret=iret) +! if(iret == 0) then +! tprec = 1.0*ifhr-zhour +! tclod = tprec +! trdlw = tprec +! trdsw = tprec +! tsrfc = tprec +! tmaxmin = tprec +! td3d = tprec +! print*,'tprec from flux file header= ',tprec +! else +! print*,'Error reading accumulation bucket from flux file', & +! 'header - will try to read from env variable FHZER' +! CALL GETENV('FHZER',ENVAR) +! read(ENVAR, '(I2)')idum +! tprec = idum*1.0 +! tclod = tprec +! trdlw = tprec +! trdsw = tprec +! tsrfc = tprec +! tmaxmin = tprec +! td3d = tprec +! print*,'TPREC from FHZER= ',tprec +! end if + + + tprec = float(fhzero) + if(ifhr>240)tprec=12. + tclod = tprec + trdlw = tprec + trdsw = tprec + tsrfc = tprec + tmaxmin = tprec + td3d = tprec + print*,'tprec = ',tprec + + +! start reading 2d netcdf file +! surface pressure +! VarName='pressfc' +! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & +! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & +! ,pint(1,jsta_2l,lp1)) +! if(debugprint)print*,'sample ',VarName,' =',pint(isa,jsa,lp1) +! do l=lm,1,-1 +! do j=jsta,jend +! do i=1,im +! pint(i,j,l)=pint(i,j,l+1)-dpres(i,j,l) +! if(pint(i,j,l)>1.0E6)print*,'bad P ',i,j,l,pint(i,j,l) & +! ,pint(i,j,l+1),dpres(i,j,l) +! end do +! end do +! print*,'sample pint= ',isa,jsa,l,pint(isa,jsa,l) +! end do +! surface height from FV3 already multiplied by G +! VarName='orog' +! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & +! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,fis) +! if(debugprint)print*,'sample ',VarName,' =',fis(isa,jsa) +! do j=jsta,jend +! do i=1,im +! if (fis(i,j) /= spval) then +! zint(i,j,lp1) = fis(i,j) +! fis(i,j) = fis(i,j) * grav +! else +! zint(i,j,lp1) = spval +! fis(i,j) = spval +! endif +! enddo +! enddo + +! do l=lm,1,-1 +! do j=jsta,jend +! do i=1,im +! if(zint(i,j,l+1)/=spval .and. buf3d(i,j,l)/=spval)then +! zint(i,j,l)=zint(i,j,l+1)+buf3d(i,j,l) +! if(zint(i,j,l)>1.0E6)print*,'bad H ',i,j,l,zint(i,j,l) +! else +! zint(i,j,l)=spval +! end if +! end do +! end do +! print*,'sample zint= ',isa,jsa,l,zint(isa,jsa,l) +! end do + +! Per communication with Fanglin, P from model in not monotonic +! so compute P using ak and bk for now Sep. 2017 +! do l=lm,1,-1 +!!!$omp parallel do private(i,j) +! do j=jsta,jend +! do i=1,im +! pint(i,j,l) = ak5(lm+2-l) + bk5(lm+2-l)*pint(i,j,lp1) +! pmid(i,j,l) = 0.5*(pint(i,j,l)+pint(i,j,l+1)) ! for now - +! enddo +! enddo +! print*,'sample pint,pmid' & +! ,l,pint(isa,jsa,l),pmid(isa,jsa,l) +! enddo + +! allocate(wrk1(im,jsta:jend),wrk2(im,jsta:jend)) +! do j=jsta,jend +! do i=1,im +! pd(i,j) = spval ! GFS does not output PD +! pint(i,j,1) = PT +! alpint(i,j,lp1) = log(pint(i,j,lp1)) +! wrk1(i,j) = log(PMID(I,J,LM)) +! wrk2(i,j) = T(I,J,LM)*(Q(I,J,LM)*fv+1.0) +! FI(I,J,1) = FIS(I,J) & +! + wrk2(i,j)*rgas*(ALPINT(I,J,Lp1)-wrk1(i,j)) +! ZMID(I,J,LM) = FI(I,J,1) * gravi +! end do +! end do + +! SECOND, INTEGRATE HEIGHT HYDROSTATICLY, GFS integrate height on +! mid-layer + +! DO L=LM,2,-1 ! omit computing model top height +! ll = l - 1 +! do j = jsta, jend +! do i = 1, im +! alpint(i,j,l) = log(pint(i,j,l)) +! tvll = T(I,J,LL)*(Q(I,J,LL)*fv+1.0) +! pmll = log(PMID(I,J,LL)) + +! FI(I,J,2) = FI(I,J,1) + (0.5*rgas)*(wrk2(i,j)+tvll) & +! * (wrk1(i,j)-pmll) +! ZMID(I,J,LL) = FI(I,J,2) * gravi +! +! FACT = (ALPINT(I,J,L)-wrk1(i,j)) / (pmll-wrk1(i,j)) +! ZINT(I,J,L) = ZMID(I,J,L) +(ZMID(I,J,LL)-ZMID(I,J,L))*FACT +! FI(I,J,1) = FI(I,J,2) +! wrk1(i,J) = pmll +! wrk2(i,j) = tvll +! ENDDO +! ENDDO + +! print*,'L ZINT= ',l,zint(isa,jsa,l),ZMID(isa,jsa,l) +! ,'alpint=',ALPINT(ii,jj,l),'pmid=',LOG(PMID(Ii,Jj,L)), & +! 'pmid(l-1)=',LOG(PMID(Ii,Jj,L-1)),'zmd=',ZMID(Ii,Jj,L), & +! 'zmid(l-1)=',ZMID(Ii,Jj,L-1) +! ENDDO +! deallocate(wrk1,wrk2) + +! do l=lp1,2,-1 +! do j=jsta,jend +! do i=1,im +! alpint(i,j,l)=log(pint(i,j,l)) +! end do +! end do +! end do + +! do l=lm,2,-1 +! do j=jsta,jend +! do i=1,im +! zmid(i,j,l)=zint(i,j,l+1)+(zint(i,j,l)-zint(i,j,l+1))* & +! (log(pmid(i,j,l))-alpint(i,j,l+1))/ & +! (alpint(i,j,l)-alpint(i,j,l+1)) +! if(zmid(i,j,l)>1.0E6)print*,'bad Hmid ',i,j,l,zmid(i,j,l) +! end do +! end do +! end do + +! VarName='refl_10cm' +! do l=1,lm +! call read_netcdf_3d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & +! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & +! ,lm,REF_10CM(1,jsta_2l,1)) +! if(debugprint)print*,'sample ',VarName,'isa,jsa,l =' & +! ,REF_10CM(isa,jsa,l),isa,jsa,l +! enddo +!Set REF_10CM as missning since gfs doesn't ouput it + do l=1,lm + do j=jsta,jend + do i=1,im + REF_10CM(i,j,l)=spval + enddo + enddo + enddo + + VarName='land' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sm) + if(debugprint)print*,'sample ',VarName,' =',sm(im/2,(jsta+jend)/2) + +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (sm(i,j) /= spval) sm(i,j) = 1.0 - sm(i,j) + enddo + enddo + +! sea ice mask + + VarName = 'icec' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sice) + if(debugprint)print*,'sample ',VarName,' = ',sice(isa,jsa) + +! where(sice /=spval .and. sice >=1.0)sm=0.0 !sea ice has sea +! mask=0 +! GFS flux files have land points with non-zero sea ice, per Iredell, +! these +! points have sea ice changed to zero, i.e., trust land mask more than +! sea ice +! where(sm/=spval .and. sm==0.0)sice=0.0 !specify sea ice=0 at land + +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (sm(i,j) /= spval .and. sm(i,j) == 0.0) sice(i,j) = 0.0 + enddo + enddo + + +! PBL height using nemsio + VarName = 'hpbl' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,pblh) + if(debugprint)print*,'sample ',VarName,' = ',pblh(isa,jsa) + +! frictional velocity using nemsio + VarName='fricv' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,ustar) +! if(debugprint)print*,'sample ',VarName,' = ',ustar(isa,jsa) + +! roughness length using getgb + VarName='sfcr' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,z0) +! if(debugprint)print*,'sample ',VarName,' = ',z0(isa,jsa) + +! sfc exchange coeff + VarName='sfexc' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,SFCEXC) + +! aerodynamic conductance + VarName='acond' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,acond) + if(debugprint)print*,'sample ',VarName,' = ',acond(isa,jsa) +! mid day avg albedo + VarName='albdo_ave' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgalbedo) + if(debugprint)print*,'sample ',VarName,' = ',avgalbedo(isa,jsa) + do j=jsta,jend + do i=1,im + if (avgalbedo(i,j) /= spval) avgalbedo(i,j) = avgalbedo(i,j) * 0.01 + enddo + enddo + +! surface potential T using getgb + VarName='tmpsfc' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,ths) + +! where(ths/=spval)ths=ths*(p1000/pint(:,:,lp1))**CAPA ! convert to THS + +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (ths(i,j) /= spval) then +! write(0,*)' i=',i,' j=',j,' ths=',ths(i,j),' pint=',pint(i,j,lp1) + ths(i,j) = ths(i,j) * (p1000/pint(i,j,lp1))**capa + endif + QS(i,j) = SPVAL ! GFS does not have surface specific humidity + twbs(i,j) = SPVAL ! GFS does not have inst sensible heat flux + qwbs(i,j) = SPVAL ! GFS does not have inst latent heat flux +!assign sst + if (sm(i,j) /= 0.0) then + sst(i,j) = ths(i,j) * (pint(i,j,lp1)/p1000)**capa + else + sst(i,j) = spval + endif + enddo + enddo + if(debugprint)print*,'sample ',VarName,' = ',ths(isa,jsa) + + +! GFS does not have time step and physics time step, make up ones since they +! are not really used anyway +! NPHS=1. +! DT=90. +! DTQ2 = DT * NPHS !MEB need to get physics DT + DTQ2 = DTP !MEB need to get physics DT + NPHS=1 + DT = DTQ2/NPHS !MEB need to get DT + TSPH = 3600./DT + +! convective precip in m per physics time step using getgb +! read 3 hour bucket + VarName='cpratb_ave' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgcprate) +! where(avgcprate /= spval)avgcprate=avgcprate*dtq2/1000. ! convert to m +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (avgcprate(i,j) /= spval) avgcprate(i,j) = avgcprate(i,j) * (dtq2*0.001) + enddo + enddo +! if(debugprint)print*,'sample ',VarName,' = ',avgcprate(isa,jsa) + +! print*,'maxval CPRATE: ', maxval(CPRATE) + +! read continuous bucket + VarName='cprat_ave' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgcprate_cont) +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (avgcprate_cont(i,j) /= spval) avgcprate_cont(i,j) = & + avgcprate_cont(i,j) * (dtq2*0.001) + enddo + enddo +! if(debugprint)print*,'sample ',VarName,' = ',avgcprate_cont(isa,jsa) + +! print*,'maxval CPRATE: ', maxval(CPRATE) + +! precip rate in m per physics time step using getgb + VarName='prateb_ave' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgprec) +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if(avgprec(i,j) /= spval)avgprec(i,j)=avgprec(i,j)*(dtq2*0.001) + enddo + enddo + + if(debugprint)print*,'sample ',VarName,' = ',avgprec(isa,jsa) + +! prec = avgprec !set avg cprate to inst one to derive other fields + + VarName='prate_ave' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgprec_cont) +! where(avgprec /= spval)avgprec=avgprec*dtq2/1000. ! convert to m +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (avgprec_cont(i,j) /=spval)avgprec_cont(i,j)=avgprec_cont(i,j) & + * (dtq2*0.001) + enddo + enddo + + if(debugprint)print*,'sample ',VarName,' = ',avgprec_cont(isa,jsa) +! precip rate in m per physics time step + VarName='tprcp' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,prec) +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (prec(i,j) /= spval) prec(i,j)=prec(i,j)* (dtq2*0.001) & + * 1000. / dtp + enddo + enddo + +! convective precip rate in m per physics time step + VarName='cnvprcp' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,cprate) +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (cprate(i,j) /= spval) then + cprate(i,j) = max(0.,cprate(i,j)) * (dtq2*0.001) & + * 1000. / dtp + else + cprate(i,j) = 0. + endif + enddo + enddo + if(debugprint)print*,'sample ',VarName,' = ',cprate(isa,jsa) + +! GFS does not have accumulated total, gridscale, and convective precip, will use inst precip to derive in SURFCE.f + +! max hourly 1-km agl reflectivity +! VarName='refdmax' +! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & +! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,refd_max) +! if(debugprint)print*,'sample ',VarName,' = ',refd_max(isa,jsa) +! max hourly -10C reflectivity +! VarName='refdmax263k' +! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & +! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,refdm10c_max) +! if(debugprint)print*,'sample ',VarName,' = ',refdm10c_max(isa,jsa) + +! max hourly u comp of 10m agl wind +! VarName='u10max' +! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & +! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,u10max) +! if(debugprint)print*,'sample ',VarName,' = ',u10max(isa,jsa) +! max hourly v comp of 10m agl wind +! VarName='v10max' +! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & +! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,v10max) +! if(debugprint)print*,'sample ',VarName,' = ',v10max(isa,jsa) +! max hourly 10m agl wind speed +! VarName='spd10max' +! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & +! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,wspd10max) +! if(debugprint)print*,'sample ',VarName,' = ',wspd10max(isa,jsa) + + +! 2m T using nemsio + VarName='tmp2m' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,tshltr) + if(debugprint)print*,'sample ',VarName,' = ',tshltr(isa,jsa) + +! inst snow water eqivalent using nemsio + VarName='weasd' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sno) +! mask water areas +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (sm(i,j) == 1.0 .and. sice(i,j)==0.) sno(i,j) = spval + enddo + enddo + if(debugprint)print*,'sample ',VarName,' = ',sno(isa,jsa) + +! ave snow cover + VarName='snowc_ave' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,snoavg) +! snow cover is multipled by 100 in SURFCE before writing it out + do j=jsta,jend + do i=1,im + if (sm(i,j)==1.0 .and. sice(i,j)==0.) snoavg(i,j)=spval + if(snoavg(i,j)/=spval)snoavg(i,j)=snoavg(i,j)/100. + end do + end do + +! snow depth in mm using nemsio + VarName='snod' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,si) +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (sm(i,j)==1.0 .and. sice(i,j)==0.) si(i,j)=spval + if (si(i,j) /= spval) si(i,j) = si(i,j) * 1000.0 + CLDEFI(i,j) = SPVAL ! GFS does not have convective cloud efficiency + lspa(i,j) = spval ! GFS does not have similated precip + TH10(i,j) = SPVAL ! GFS does not have 10 m theta + TH10(i,j) = SPVAL ! GFS does not have 10 m theta + Q10(i,j) = SPVAL ! GFS does not have 10 m humidity + ALBASE(i,j) = SPVAL ! GFS does not have snow free albedo + enddo + enddo + if(debugprint)print*,'sample ',VarName,' = ',si(isa,jsa) + +! 2m T using nemsio + VarName='tmp2m' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,tshltr) + if(debugprint)print*,'sample ',VarName,' = ',tshltr(isa,jsa) + +! GFS does not have 2m pres, estimate it, also convert t to theta + Do j=jsta,jend + Do i=1,im + PSHLTR(I,J)=pint(I,J,lm+1)*EXP(-0.068283/tshltr(i,j)) + tshltr(i,j)= tshltr(i,j)*(p1000/PSHLTR(I,J))**CAPA ! convert to theta +! if (j == jm/2 .and. mod(i,50) == 0) +! + print*,'sample 2m T and P after scatter= ' +! + ,i,j,tshltr(i,j),pshltr(i,j) + end do + end do + +! 2m specific humidity using nemsio + VarName='spfh2m' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,qshltr) + if(debugprint)print*,'sample ',VarName,' = ',qshltr(isa,jsa) + +! mid day avg albedo in fraction using nemsio +! VarName='albdosfc' +! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & +! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgalbedo) +!! where(avgalbedo /= spval)avgalbedo=avgalbedo/100. ! convert to fraction +!!$omp parallel do private(i,j) +! do j=jsta,jend +! do i=1,im +! if (avgalbedo(i,j) /= spval) avgalbedo(i,j) = avgalbedo(i,j) * 0.01 +! enddo +! enddo +! if(debugprint)print*,'sample ',VarName,' = ',avgalbedo(isa,jsa) + +! time averaged column cloud fractionusing nemsio + VarName='tcdc_aveclm' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgtcdc) +! where(avgtcdc /= spval)avgtcdc=avgtcdc/100. ! convert to fraction +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (avgtcdc(i,j) /= spval) avgtcdc(i,j) = avgtcdc(i,j) * 0.01 + enddo + enddo + if(debugprint)print*,'sample ',VarName,' = ',avgtcdc(isa,jsa) + +! GFS probably does not use zenith angle +!$omp parallel do private(i,j) + do j=jsta_2l,jend_2u + do i=1,im + Czen(i,j) = spval + CZMEAN(i,j) = SPVAL + enddo + enddo + +! maximum snow albedo in fraction using nemsio + VarName='snoalb' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,mxsnal) +! where(mxsnal /= spval)mxsnal=mxsnal/100. ! convert to fraction +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (mxsnal(i,j) /= spval) mxsnal(i,j) = mxsnal(i,j) * 0.01 + enddo + enddo +! if(debugprint)print*,'sample ',VarName,' = ',mxsnal(isa,jsa) + +! GFS probably does not use sigt4, set it to sig*t^4 +!$omp parallel do private(i,j,tlmh) + Do j=jsta,jend + Do i=1,im + TLMH = T(I,J,LM) * T(I,J,LM) + Sigt4(i,j) = 5.67E-8 * TLMH * TLMH + End do + End do + +! TG is not used, skip it for now + +! GFS does not have inst cloud fraction for high, middle, and low cloud +!$omp parallel do private(i,j) + do j=jsta_2l,jend_2u + do i=1,im + cfrach(i,j) = spval + cfracl(i,j) = spval + cfracm(i,j) = spval + enddo + enddo + +! ave high cloud fraction using nemsio + VarName='tcdc_avehcl' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgcfrach) +! where(avgcfrach /= spval)avgcfrach=avgcfrach/100. ! convert to fraction +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (avgcfrach(i,j) /= spval) avgcfrach(i,j) = avgcfrach(i,j) * 0.01 + enddo + enddo + if(debugprint)print*,'sample ',VarName,' = ',avgcfrach(isa,jsa) + +! ave low cloud fraction using nemsio + VarName='tcdc_avelcl' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgcfracl) +! where(avgcfracl /= spval)avgcfracl=avgcfracl/100. ! convert to fraction +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (avgcfracl(i,j) /= spval) avgcfracl(i,j) = avgcfracl(i,j) * 0.01 + enddo + enddo + if(debugprint)print*,'sample ',VarName,' = ',avgcfracl(isa,jsa) + +! ave middle cloud fraction using nemsio + VarName='tcdc_avemcl' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgcfracm) +! where(avgcfracm /= spval)avgcfracm=avgcfracm/100. ! convert to fraction +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (avgcfracm(i,j) /= spval) avgcfracm(i,j) = avgcfracm(i,j) * 0.01 + enddo + enddo + if(debugprint)print*,'sample ',VarName,' = ',avgcfracm(isa,jsa) + +! inst convective cloud fraction using nemsio + VarName='tcdccnvcl' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,cnvcfr) +! where(cnvcfr /= spval)cnvcfr=cnvcfr/100. ! convert to fraction +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (cnvcfr(i,j) /= spval) cnvcfr (i,j)= cnvcfr(i,j) * 0.01 + enddo + enddo +! if(debugprint)print*,'sample ',VarName,' = ',cnvcfr(isa,jsa) + +! slope type using nemsio + VarName='sltyp' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,buf) +!$omp parallel do private(i,j) + do j = jsta_2l, jend_2u + do i=1,im + if (buf(i,j) < spval) then + islope(i,j) = nint(buf(i,j)) + else + islope(i,j) = 0 + endif + enddo + enddo +! if(debugprint)print*,'sample ',VarName,' = ',islope(isa,jsa) + +! plant canopy sfc wtr in m + VarName='cnwat' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,cmc) +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (cmc(i,j) /= spval) cmc(i,j) = cmc(i,j) * 0.001 + if (sm(i,j) /= 0.0) cmc(i,j) = spval + enddo + enddo +! if(debugprint)print*,'sample ',VarName,' = ',cmc(isa,jsa) + +!$omp parallel do private(i,j) + do j=jsta_2l,jend_2u + do i=1,im + grnflx(i,j) = spval ! GFS does not have inst ground heat flux + enddo + enddo + +! frozen precip fraction using nemsio + VarName='cpofp' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sr) +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if(sr(i,j) /= spval) then +!set range within (0,1) + sr(i,j)=min(1.,max(0.,sr(i,j))) + endif + enddo + enddo + +! sea ice skin temperature + VarName='tisfc' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,ti) +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (sice(i,j) == spval .or. sice(i,j) == 0.) ti(i,j)=spval + enddo + enddo + +! vegetation fraction in fraction. using nemsio + VarName='veg' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,vegfrc) +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (vegfrc(i,j) /= spval) then + vegfrc(i,j) = vegfrc(i,j) * 0.01 + else + vegfrc(i,j) = 0.0 + endif + enddo + enddo +! mask water areas +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (sm(i,j) /= 0.0) vegfrc(i,j) = spval + enddo + enddo +! if(debugprint)print*,'sample ',VarName,' = ',vegfrc(isa,jsa) + +! GFS doesn not yet output soil layer thickness, assign SLDPTH to be the same as nam + + SLDPTH(1) = 0.10 + SLDPTH(2) = 0.3 + SLDPTH(3) = 0.6 + SLDPTH(4) = 1.0 + +! liquid volumetric soil mpisture in fraction using nemsio + VarName='soill1' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sh2o(1,jsta_2l,1)) +! mask water areas +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (sm(i,j) /= 0.0) sh2o(i,j,1) = spval + enddo + enddo + if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,1) + + VarName='soill2' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sh2o(1,jsta_2l,2)) +! mask water areas +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (sm(i,j) /= 0.0) sh2o(i,j,2) = spval + enddo + enddo + if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,2) + + VarName='soill3' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sh2o(1,jsta_2l,3)) +! mask water areas +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (sm(i,j) /= 0.0) sh2o(i,j,3) = spval + enddo + enddo + if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,3) + + VarName='soill4' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sh2o(1,jsta_2l,4)) +! mask water areas +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (sm(i,j) /= 0.0) sh2o(i,j,4) = spval + enddo + enddo + if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,4) + +! volumetric soil moisture using nemsio + VarName='soilw1' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,smc(1,jsta_2l,1)) +! mask water areas +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (sm(i,j) /= 0.0) smc(i,j,1) = spval + enddo + enddo + if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,1) + + VarName='soilw2' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,smc(1,jsta_2l,2)) +! mask water areas +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (sm(i,j) /= 0.0) smc(i,j,2) = spval + enddo + enddo + if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,2) + + VarName='soilw3' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,smc(1,jsta_2l,3)) +! mask water areas +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (sm(i,j) /= 0.0) smc(i,j,3) = spval + enddo + enddo + if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,3) + + VarName='soilw4' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,smc(1,jsta_2l,4)) +! mask water areas +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (sm(i,j) /= 0.0) smc(i,j,4) = spval + enddo + enddo + if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,4) + +! soil temperature using nemsio + VarName='soilt1' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,stc(1,jsta_2l,1)) +! mask open water areas, combine with sea ice tmp +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,1) = spval + !if (sm(i,j) /= 0.0) stc(i,j,1) = spval + enddo + enddo + if(debugprint)print*,'sample l','stc',' = ',1,stc(isa,jsa,1) + + VarName='soilt2' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,stc(1,jsta_2l,2)) +! mask open water areas, combine with sea ice tmp +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,2) = spval + !if (sm(i,j) /= 0.0) stc(i,j,2) = spval + enddo + enddo + if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,2) + + VarName='soilt3' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,stc(1,jsta_2l,3)) +! mask open water areas, combine with sea ice tmp +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,3) = spval + !if (sm(i,j) /= 0.0) stc(i,j,3) = spval + enddo + enddo + if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,3) + + VarName='soilt4' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,stc(1,jsta_2l,4)) +! mask open water areas, combine with sea ice tmp +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,4) = spval + !if (sm(i,j) /= 0.0) stc(i,j,4) = spval + enddo + enddo + if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,4) + +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + acfrcv(i,j) = spval ! GFS does not output time averaged convective and strat cloud fraction, set acfrcv to spval, ncfrcv to 1 + ncfrcv(i,j) = 1.0 + acfrst(i,j) = spval ! GFS does not output time averaged cloud fraction, set acfrst to spval, ncfrst to 1 + ncfrst(i,j) = 1.0 + bgroff(i,j) = spval ! GFS does not have UNDERGROUND RUNOFF + rlwtoa(i,j) = spval ! GFS does not have inst model top outgoing longwave + enddo + enddo +! trdlw(i,j) = 6.0 + ardlw = 1.0 ! GFS incoming sfc longwave has been averaged over 6 hr bucket, set ARDLW to 1 + +! time averaged incoming sfc longwave + VarName='dlwrf_ave' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,alwin) + +! inst incoming sfc longwave + VarName='dlwrf' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,rlwin) + +! time averaged outgoing sfc longwave + VarName='ulwrf_ave' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,alwout) +! inst outgoing sfc longwave + VarName='ulwrf' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,radot) + +! where(alwout /= spval) alwout=-alwout ! CLDRAD puts a minus sign before gribbing +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (alwout(i,j) /= spval) alwout(i,j) = -alwout(i,j) + enddo + enddo +! if(debugprint)print*,'sample l',VarName,' = ',1,alwout(isa,jsa) + +! time averaged outgoing model top longwave using gfsio + VarName='ulwrf_avetoa' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,alwtoa) +! if(debugprint)print*,'sample l',VarName,' = ',1,alwtoa(isa,jsa) + +! GFS incoming sfc longwave has been averaged, set ARDLW to 1 + ardsw=1.0 +! trdsw=6.0 + +! time averaged incoming sfc shortwave + VarName='dswrf_ave' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,aswin) +! if(debugprint)print*,'sample l',VarName,' = ',1,aswin(isa,jsa) + +! inst incoming sfc shortwave + VarName='dswrf' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,rswin) + +! inst incoming clear sky sfc shortwave + VarName='csdlf' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,rswinc) + +! time averaged incoming sfc uv-b using getgb + VarName='duvb_ave' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,auvbin) +! if(debugprint)print*,'sample l',VarName,' = ',1,auvbin(isa,jsa) + +! time averaged incoming sfc clear sky uv-b using getgb + VarName='cduvb_ave' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,auvbinc) +! if(debugprint)print*,'sample l',VarName,' = ',1,auvbinc(isa,jsa) + +! time averaged outgoing sfc shortwave using gfsio + VarName='uswrf_ave' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,aswout) +! where(aswout /= spval) aswout=-aswout ! CLDRAD puts a minus sign before gribbing +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (aswout(i,j) /= spval) aswout(i,j) = -aswout(i,j) + enddo + enddo +! if(debugprint)print*,'sample l',VarName,' = ',1,aswout(isa,jsa) + +! inst outgoing sfc shortwave using gfsio + VarName='uswrf' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,rswout) + +! time averaged model top incoming shortwave + VarName='dswrf_avetoa' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,aswintoa) +! if(debugprint)print*,'sample l',VarName,' = ',1,aswintoa(isa,jsa) + +! time averaged model top outgoing shortwave + VarName='uswrf_avetoa' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,aswtoa) +! if(debugprint)print*,'sample l',VarName,' = ',1,aswtoa(isa,jsa) + +! time averaged surface sensible heat flux, multiplied by -1 because wrf model flux +! has reversed sign convention using gfsio + VarName='shtfl_ave' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sfcshx) +! where (sfcshx /= spval)sfcshx=-sfcshx +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (sfcshx(i,j) /= spval) sfcshx(i,j) = -sfcshx(i,j) + enddo + enddo +! if(debugprint)print*,'sample l',VarName,' = ',1,sfcshx(isa,jsa) + +! inst surface sensible heat flux + VarName='shtfl' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,twbs) +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (twbs(i,j) /= spval) twbs(i,j) = -twbs(i,j) + enddo + enddo + +! GFS surface flux has been averaged, set ASRFC to 1 + asrfc=1.0 +! tsrfc=6.0 + +! time averaged surface latent heat flux, multiplied by -1 because wrf model flux +! has reversed sign vonvention using gfsio + VarName='lhtfl_ave' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sfclhx) +! where (sfclhx /= spval)sfclhx=-sfclhx +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (sfclhx(i,j) /= spval) sfclhx(i,j) = -sfclhx(i,j) + enddo + enddo +! if(debugprint)print*,'sample l',VarName,' = ',1,sfclhx(isa,jsa) + +! inst surface latent heat flux + VarName='lhtfl' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,qwbs) +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (qwbs(i,j) /= spval) qwbs(i,j) = -qwbs(i,j) + enddo + enddo + + if(me==0)print*,'rdaod= ',rdaod +! inst aod550 optical depth + if(rdaod) then + VarName='aod550' + call read_netcdf_2d_scatter(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + spval,VarName,aod550) + + VarName='du_aod550' + call read_netcdf_2d_scatter(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + spval,VarName,du_aod550) + + VarName='ss_aod550' + call read_netcdf_2d_scatter(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + spval,VarName,ss_aod550) + + VarName='su_aod550' + call read_netcdf_2d_scatter(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + spval,VarName,su_aod550) + + VarName='oc_aod550' + call read_netcdf_2d_scatter(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + spval,VarName,oc_aod550) + + VarName='bc_aod550' + call read_netcdf_2d_scatter(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + spval,VarName,bc_aod550) + end if + +! time averaged ground heat flux using nemsio + VarName='gflux_ave' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,subshx) +! mask water areas +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) subshx(i,j) = spval + enddo + enddo +! if(debugprint)print*,'sample l',VarName,' = ',1,subshx(isa,jsa) + +! inst ground heat flux using nemsio + VarName='gflux' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,grnflx) +! mask water areas +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) grnflx(i,j) = spval + enddo + enddo + +! time averaged zonal momentum flux using gfsio + VarName='uflx_ave' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sfcux) +! if(debugprint)print*,'sample l',VarName,' = ',1,sfcux(isa,jsa) + +! time averaged meridional momentum flux using nemsio + VarName='vflx_ave' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sfcvx) +! if(debugprint)print*,'sample l',VarName,' = ',1,sfcvx(isa,jsa) + +! dong read in inst surface flux +! inst zonal momentum flux using gfsio +! VarName='uflx' +! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & +! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sfcuxi) +! if(debugprint)print*,'sample l',VarName,' = ',1,sfcuxi(isa,jsa) + +! inst meridional momentum flux using nemsio +! VarName='vflx' +! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & +! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sfcvxi) +! if(debugprint)print*,'sample l',VarName,' = ',1,sfcvxi(isa,jsa) + + +!$omp parallel do private(i,j) + do j=jsta_2l,jend_2u + do i=1,im + sfcuvx(i,j) = spval ! GFS does not use total momentum flux + enddo + enddo + +! time averaged zonal gravity wave stress using nemsio + VarName='u-gwd_ave' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,gtaux) +! if(debugprint)print*,'sample l',VarName,' = ',1,gtaux(isa,jsa) + +! time averaged meridional gravity wave stress using getgb + VarName='v-gwd_ave' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,gtauy) +! if(debugprint)print*,'sample l',VarName,' = ',1,gtauy(isa,jsa) + +! time averaged accumulated potential evaporation + VarName='pevpr_ave' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgpotevp) +! mask water areas +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) avgpotevp(i,j) = spval + enddo + enddo +! if(debugprint)print*,'sample l',VarName,' = ',1,potevp(isa,jsa) + +! inst potential evaporation + VarName='pevpr' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,potevp) +! mask water areas +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) potevp(i,j) = spval + enddo + enddo + + do l=1,lm +!$omp parallel do private(i,j) + do j=jsta_2l,jend_2u + do i=1,im +! GFS does not have temperature tendency due to long wave radiation + rlwtt(i,j,l) = spval +! GFS does not have temperature tendency due to short wave radiation + rswtt(i,j,l) = spval +! GFS does not have temperature tendency due to latent heating from convection + tcucn(i,j,l) = spval + tcucns(i,j,l) = spval +! GFS does not have temperature tendency due to latent heating from grid scale + train(i,j,l) = spval + enddo + enddo + enddo + +! set avrain to 1 + avrain=1.0 + avcnvc=1.0 + theat=6.0 ! just in case GFS decides to output T tendency + +! 10 m u using nemsio + VarName='ugrd10m' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,u10) + + do j=jsta,jend + do i=1,im + u10h(i,j)=u10(i,j) + end do + end do +! if(debugprint)print*,'sample l',VarName,' = ',1,u10(isa,jsa) + +! 10 m v using gfsio + VarName='vgrd10m' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,v10) + + do j=jsta,jend + do i=1,im + v10h(i,j)=v10(i,j) + end do + end do +! if(debugprint)print*,'sample l',VarName,' = ',1,v10(isa,jsa) + +! vegetation type, it's in GFS surface file, hopefully will merge into gfsio soon + VarName='vtype' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,buf) +! where (buf /= spval) +! ivgtyp=nint(buf) +! elsewhere +! ivgtyp=0 !need to feed reasonable value to crtm +! end where +!$omp parallel do private(i,j) + do j = jsta_2l, jend_2u + do i=1,im + if (buf(i,j) < spval) then + ivgtyp(i,j) = nint(buf(i,j)) + else + ivgtyp(i,j) = 0 + endif + enddo + enddo +! if(debugprint)print*,'sample l',VarName,' = ',1,ivgtyp(isa,jsa) + +! soil type, it's in GFS surface file, hopefully will merge into gfsio soon + VarName='sotyp' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,buf) + VcoordName='sfc' + l=1 +!$omp parallel do private(i,j) + do j = jsta_2l, jend_2u + do i=1,im + if (buf(i,j) < spval) then + isltyp(i,j) = nint(buf(i,j)) + else + isltyp(i,j) = 0 !need to feed reasonable value to crtm + endif + enddo + enddo +! if(debugprint)print*,'sample l',VarName,' = ',1,isltyp(isa,jsa) + +!$omp parallel do private(i,j) + do j=jsta_2l,jend_2u + do i=1,im + smstav(i,j) = spval ! GFS does not have soil moisture availability +! smstot(i,j) = spval ! GFS does not have total soil moisture + sfcevp(i,j) = spval ! GFS does not have accumulated surface evaporation + acsnow(i,j) = spval ! GFS does not have averaged accumulated snow + acsnom(i,j) = spval ! GFS does not have snow melt +! sst(i,j) = spval ! GFS does not have sst???? + thz0(i,j) = ths(i,j) ! GFS does not have THZ0, use THS to substitute + qz0(i,j) = spval ! GFS does not output humidity at roughness length + uz0(i,j) = spval ! GFS does not output u at roughness length + vz0(i,j) = spval ! GFS does not output humidity at roughness length + enddo + enddo + do l=1,lm +!$omp parallel do private(i,j) + do j=jsta_2l,jend_2u + do i=1,im + EL_PBL(i,j,l) = spval ! GFS does not have mixing length + exch_h(i,j,l) = spval ! GFS does not output exchange coefficient + enddo + enddo + enddo +! if(debugprint)print*,'sample l',VarName,' = ',1,thz0(isa,jsa) + +! retrieve inst convective cloud top, GFS has cloud top pressure instead of index, +! will need to modify CLDRAD.f to use pressure directly instead of index +! VarName='pres' +! VcoordName='convect-cld top' +! l=1 +! if(debugprint)print*,'sample l',VarName,' = ',1,ptop(isa,jsa) + VarName='prescnvclt' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,ptop) + + +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + htop(i,j) = spval + if(ptop(i,j) <= 0.0) ptop(i,j) = spval + enddo + enddo + do j=jsta,jend + do i=1,im + if(ptop(i,j) < spval)then + do l=1,lm + if(ptop(i,j) <= pmid(i,j,l))then + htop(i,j) = l +! if(i==ii .and. j==jj)print*,'sample ptop,pmid pmid-1,pint= ', & +! ptop(i,j),pmid(i,j,l),pmid(i,j,l-1),pint(i,j,l),htop(i,j) + exit + end if + end do + end if + end do + end do + +! retrieve inst convective cloud bottom, GFS has cloud top pressure instead of index, +! will need to modify CLDRAD.f to use pressure directly instead of index + VarName='prescnvclb' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,pbot) +! if(debugprint)print*,'sample l',VarName,VcoordName,' = ',1,pbot(isa,jsa) +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + hbot(i,j) = spval + if(pbot(i,j) <= 0.0) pbot(i,j) = spval + enddo + enddo + do j=jsta,jend + do i=1,im +! if(.not.lb(i,j))print*,'false bitmask for pbot at ' +! + ,i,j,pbot(i,j) + if(pbot(i,j) < spval)then + do l=lm,1,-1 + if(pbot(i,j) >= pmid(i,j,l)) then + hbot(i,j) = l +! if(i==ii .and. j==jj)print*,'sample pbot,pmid= ', & +! pbot(i,j),pmid(i,j,l),hbot(i,j) + exit + end if + end do + end if + end do + end do + if(debugprint)print*,'sample hbot = ',hbot(isa,jsa) +! retrieve time averaged low cloud top pressure using nemsio + VarName='pres_avelct' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,ptopl) +! if(debugprint)print*,'sample l',VarName,' = ',1,ptopl(isa,jsa) + +! retrieve time averaged low cloud bottom pressure using nemsio + VarName='pres_avelcb' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,pbotl) +! if(debugprint)print*,'sample l',VarName,' = ',1,pbotl(isa,jsa) + +! retrieve time averaged low cloud top temperature using nemsio + VarName='tmp_avelct' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,Ttopl) +! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttopl(isa,jsa) + +! retrieve time averaged middle cloud top pressure using nemsio + VarName='pres_avemct' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,ptopm) +! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,ptopm(isa,jsa) + +! retrieve time averaged middle cloud bottom pressure using nemsio + VarName='pres_avemcb' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,pbotm) +! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,pbotm(isa,jsa) + +! retrieve time averaged middle cloud top temperature using nemsio + VarName='tmp_avemct' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,Ttopm) +! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttopm(isa,jsa) + +! retrieve time averaged high cloud top pressure using nemsio ********* + VarName='pres_avehct' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,ptoph) +! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,ptoph(isa,jsa) + +! retrieve time averaged high cloud bottom pressure using nemsio + VarName='pres_avehcb' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,pboth) +! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,pboth(isa,jsa) + +! retrieve time averaged high cloud top temperature using nemsio + VarName='tmp_avehct' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,Ttoph) +! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttoph(isa,jsa) + +! retrieve boundary layer cloud cover using nemsio + VarName='tcdc_avebndcl' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,pblcfr) +! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,pblcfr(isa,jsa) +! where (pblcfr /= spval)pblcfr=pblcfr/100. ! convert to fraction +!$omp parallel do private(i,j) + do j = jsta_2l, jend_2u + do i=1,im + if (pblcfr(i,j) < spval) pblcfr(i,j) = pblcfr(i,j) * 0.01 + enddo + enddo + +! retrieve cloud work function + VarName='cwork_aveclm' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,cldwork) +! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,cldwork(isa,jsa) + +! accumulated total (base+surface) runoff + VarName='watr_acc' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,runoff) +! mask water areas +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (sm(i,j) /= 0.0) runoff(i,j) = spval + enddo + enddo +! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,runoff(isa,jsa) + +! retrieve shelter max temperature using nemsio + VarName='tmax_max2m' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,maxtshltr) + +! retrieve shelter min temperature using nemsio + VarName='tmin_min2m' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,mintshltr) +! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', & +! 1,mintshltr(im/2,(jsta+jend)/2) + +! retrieve shelter max RH +! VarName='rh02max' +! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & +! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,maxrhshltr) + +! retrieve shelter min temperature using nemsio +! VarName='rh02min' +! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & +! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,minrhshltr) +! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', & +! 1,mintshltr(im/2,(jsta+jend)/2) + +!$omp parallel do private(i,j) + do j=jsta_2l,jend_2u + do i=1,im + MAXRHSHLTR(i,j) = SPVAL + MINRHSHLTR(i,j) = SPVAL + enddo + enddo + +! retrieve ice thickness using nemsio + VarName='icetk' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,dzice) +! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,dzice(isa,jsa) + +! retrieve wilting point using nemsio + VarName='wilt' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,smcwlt) +! mask water areas +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (sm(i,j) /= 0.0) smcwlt(i,j) = spval + enddo + enddo +! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,smcwlt(isa,jsa) + +! retrieve sunshine duration using nemsio + VarName='sunsd_acc' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,suntime) + +! retrieve field capacity using nemsio + VarName='fldcp' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,fieldcapa) +! mask water areas +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (sm(i,j) /= 0.0) fieldcapa(i,j) = spval + enddo + enddo +! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,fieldcapa(isa,jsa) + +! retrieve time averaged surface visible beam downward solar flux + VarName='vbdsf_ave' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avisbeamswin) + VcoordName='sfc' + l=1 + +! retrieve time averaged surface visible diffuse downward solar flux + VarName='vddsf_ave' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avisdiffswin) + +! retrieve time averaged surface near IR beam downward solar flux + VarName='nbdsf_ave' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,airbeamswin) + +! retrieve time averaged surface near IR diffuse downward solar flux + VarName='nddsf_ave' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,airdiffswin) + +! retrieve time averaged surface clear sky outgoing LW + VarName='csulf' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,alwoutc) + +! retrieve time averaged TOA clear sky outgoing LW + VarName='csulftoa' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,alwtoac) + +! retrieve time averaged surface clear sky outgoing SW + VarName='csusf' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,aswoutc) + +! retrieve time averaged TOA clear sky outgoing LW + VarName='csusftoa' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,aswtoac) + +! retrieve time averaged surface clear sky incoming LW + VarName='csdlf' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,alwinc) + +! retrieve time averaged surface clear sky incoming SW + VarName='csdsf' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,aswinc) + +! retrieve shelter max specific humidity using nemsio + VarName='spfhmax_max2m' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,maxqshltr) +! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', +! 1,maxqshltr(isa,jsa) + +! retrieve shelter min temperature using nemsio + VarName='spfhmin_min2m' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,minqshltr) + +! retrieve storm runoff using nemsio + VarName='ssrun_acc' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,SSROFF) +! mask water areas +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (sm(i,j) /= 0.0) ssroff(i,j) = spval + enddo + enddo + +! retrieve direct soil evaporation + VarName='evbs_ave' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgedir) +! mask water areas +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (sm(i,j) /= 0.0) avgedir(i,j) = spval + enddo + enddo + +! retrieve CANOPY WATER EVAP + VarName='evcw_ave' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgecan) +! mask water areas +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (sm(i,j) /= 0.0) avgecan(i,j) = spval + enddo + enddo + +! retrieve PLANT TRANSPIRATION + VarName='trans_ave' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgetrans) +! mask water areas +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (sm(i,j) /= 0.0) avgetrans(i,j) = spval + enddo + enddo + +! retrieve snow sublimation + VarName='sbsno_ave' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgesnow) +! mask water areas +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (sm(i,j)==1.0 .and. sice(i,j)==0.) avgesnow(i,j)=spval + enddo + enddo + +! retrive total soil moisture + VarName='soilm' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,smstot) +! mask water areas +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (sm(i,j) /= 0.0) smstot(i,j) = spval + enddo + enddo + +! retrieve snow phase change heat flux + VarName='snohf' + call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,snopcx) +! mask water areas +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (sm(i,j) /= 0.0) snopcx(i,j) = spval + enddo + enddo + +! GFS does not have deep convective cloud top and bottom fields + +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + HTOPD(i,j) = SPVAL + HBOTD(i,j) = SPVAL + HTOPS(i,j) = SPVAL + HBOTS(i,j) = SPVAL + CUPPT(i,j) = SPVAL + enddo + enddo + +! done with flux file, close it for now + Status=nf90_close(ncid2d) +! deallocate(tmp,recname,reclevtyp,reclev) + +! pos east +! call collect_loc(gdlat,dummy) +! if(me == 0)then +! latstart = nint(dummy(1,1)*gdsdegr) +! latlast = nint(dummy(im,jm)*gdsdegr) +! print*,'laststart,latlast B bcast= ',latstart,latlast,'gdsdegr=',gdsdegr,& +! 'dummy(1,1)=',dummy(1,1),dummy(im,jm),'gdlat=',gdlat(1,1) +! end if +! call mpi_bcast(latstart,1,MPI_INTEGER,0,mpi_comm_comp,irtn) +! call mpi_bcast(latlast,1,MPI_INTEGER,0,mpi_comm_comp,irtn) +! write(6,*) 'laststart,latlast,me A calling bcast=',latstart,latlast,me +! call collect_loc(gdlon,dummy) +! if(me == 0)then +! lonstart = nint(dummy(1,1)*gdsdegr) +! lonlast = nint(dummy(im,jm)*gdsdegr) +! end if +! call mpi_bcast(lonstart,1,MPI_INTEGER,0,mpi_comm_comp,irtn) +! call mpi_bcast(lonlast, 1,MPI_INTEGER,0,mpi_comm_comp,irtn) + +! write(6,*)'lonstart,lonlast A calling bcast=',lonstart,lonlast +! + +! generate look up table for lifted parcel calculations + + THL = 210. + PLQ = 70000. + pt_TBL = 10000. ! this is for 100 hPa added by Moorthi + + CALL TABLE(PTBL,TTBL,PT_TBL, & + RDQ,RDTH,RDP,RDTHE,PL,THL,QS0,SQS,STHE,THE0) + + CALL TABLEQ(TTBLQ,RDPQ,RDTHEQ,PLQ,THL,STHEQ,THE0Q) + +! +! + IF(ME == 0)THEN + WRITE(6,*)' SPL (POSTED PRESSURE LEVELS) BELOW: ' + WRITE(6,51) (SPL(L),L=1,LSM) + 50 FORMAT(14(F4.1,1X)) + 51 FORMAT(8(F8.1,1X)) + ENDIF +! +!$omp parallel do private(l) + DO L = 1,LSM + ALSL(L) = LOG(SPL(L)) + END DO +! +!HC WRITE IGDS OUT FOR WEIGHTMAKER TO READ IN AS KGDSIN + if(me == 0)then + print*,'writing out igds' + igdout = 110 +! open(igdout,file='griddef.out',form='unformatted' +! + ,status='unknown') + if(maptype == 1)THEN ! Lambert conformal + WRITE(igdout)3 + WRITE(6,*)'igd(1)=',3 + WRITE(igdout)im + WRITE(igdout)jm + WRITE(igdout)LATSTART + WRITE(igdout)LONSTART + WRITE(igdout)8 + WRITE(igdout)CENLON + WRITE(igdout)DXVAL + WRITE(igdout)DYVAL + WRITE(igdout)0 + WRITE(igdout)64 + WRITE(igdout)TRUELAT2 + WRITE(igdout)TRUELAT1 + WRITE(igdout)255 + ELSE IF(MAPTYPE == 2)THEN !Polar stereographic + WRITE(igdout)5 + WRITE(igdout)im + WRITE(igdout)jm + WRITE(igdout)LATSTART + WRITE(igdout)LONSTART + WRITE(igdout)8 + WRITE(igdout)CENLON + WRITE(igdout)DXVAL + WRITE(igdout)DYVAL + WRITE(igdout)0 + WRITE(igdout)64 + WRITE(igdout)TRUELAT2 !Assume projection at +-90 + WRITE(igdout)TRUELAT1 + WRITE(igdout)255 + ! Note: The calculation of the map scale factor at the standard + ! lat/lon and the PSMAPF + ! Get map factor at 60 degrees (N or S) for PS projection, which will + ! be needed to correctly define the DX and DY values in the GRIB GDS + if (TRUELAT1 < 0.) THEN + LAT = -60. + else + LAT = 60. + end if + + CALL MSFPS (LAT,TRUELAT1*0.001,PSMAPF) + + ELSE IF(MAPTYPE == 3) THEN !Mercator + WRITE(igdout)1 + WRITE(igdout)im + WRITE(igdout)jm + WRITE(igdout)LATSTART + WRITE(igdout)LONSTART + WRITE(igdout)8 + WRITE(igdout)latlast + WRITE(igdout)lonlast + WRITE(igdout)TRUELAT1 + WRITE(igdout)0 + WRITE(igdout)64 + WRITE(igdout)DXVAL + WRITE(igdout)DYVAL + WRITE(igdout)255 + ELSE IF(MAPTYPE == 0 .OR. MAPTYPE == 203)THEN !A STAGGERED E-GRID + WRITE(igdout)203 + WRITE(igdout)im + WRITE(igdout)jm + WRITE(igdout)LATSTART + WRITE(igdout)LONSTART + WRITE(igdout)136 + WRITE(igdout)CENLAT + WRITE(igdout)CENLON + WRITE(igdout)DXVAL + WRITE(igdout)DYVAL + WRITE(igdout)64 + WRITE(igdout)0 + WRITE(igdout)0 + WRITE(igdout)0 + END IF + end if +! +! + + RETURN + END +