diff --git a/src/gsi/ncepgfs_io.f90 b/src/gsi/ncepgfs_io.f90 index 52dcc4e1b5..8487034cef 100644 --- a/src/gsi/ncepgfs_io.f90 +++ b/src/gsi/ncepgfs_io.f90 @@ -5,7 +5,7 @@ module ncepgfs_io ! prgmmr: treadon org: np23 date: 2006-01-10 ! ! abstract: This module contains routines which handle input/output -! operations for NCEP GFS atmospheric and surface files. +! operations for ncep gfs atmospheric and surface files. ! ! program history log: ! 2006-01-10 treadon @@ -14,16 +14,16 @@ module ncepgfs_io ! reading in gefs sigma files at resolution different from analysis. ! 2010-03-31 treadon - add read_gfs, use sp_a and sp_b ! 2010-05-19 todling - add read_gfs_chem -! 2011-04-08 li - (1) add integer nst_gsi to control the mode of NSST +! 2011-04-08 li - (1) add integer nst_gsi to control the mode of nsst ! - (2) add subroutine write_gfs_sfc_nst to save sfc and nst files ! 2014-04-08 li - (1) modify write_gfs_sfc_nst for mask dependent interpolation ! (2) add write_ens_sfc_nst, write_ens_dsfct ! 2014-12-03 derber - modify for changes to general_read/write_gfsatm -! 2014-12-03 derber - modify read_sfc routines to minimize communications/IO +! 2014-12-03 derber - modify read_sfc routines to minimize communications/io ! 2015-03-13 li - introduce zsea1 & zsea2 enable to use vertical mean -! temperature based on NSST T-Profile. And move Tf analysis increment +! temperature based on nsst t-profile. And move tf analysis increment ! interpolation (analysis grid to ensemble grid) to re-center step -! 2015-04-25 li - modify read_nst, read_gfsnst routines to minimize communications/IO +! 2015-04-25 li - modify read_nst, read_gfsnst routines to minimize communications/io ! 2016-08-18 li - tic591: add read_sfc_anl & read_gfssfc_anl to read ensemble sfc file (isli only) ! use the modified 2d interpolation (sfc_interpolate to intrp22) @@ -90,9 +90,9 @@ subroutine read_gfs ! 2011-10-01 mkim - add calculation of hydrometeor mixing ratio from total condensate (cw) ! 2011-11-01 eliu - add call to set_cloud_lower_bound (qcmin) ! 2011-11-01 eliu - move then calculation of hydrometeor mixing ratio from total condensate to cloud_efr; -! rearrange Min-Jeong's code +! rearrange min-jeong's code ! 2013-10-19 todling - update cloud_efr module name -! 2013-10-29 todling - revisit write to allow skipping vars not in MetGuess +! 2013-10-29 todling - revisit write to allow skipping vars not in metguess ! 2014-11-28 zhu - assign cwgues0 right after reading in fg, ! - set lower bound to cloud after assigning cwgues0 ! @@ -164,22 +164,22 @@ subroutine read_gfs hires_b=.true. call general_init_spec_vars(sp_b,jcap_b,jcap_b,nlat,nlon_b) if (mype==0) & - write(6,*)'READ_GFS: allocate and load sp_b with jcap,imax,jmax=',& - sp_b%jcap,sp_b%imax,sp_b%jmax + write(6,*)'READ_GFS: allocate and load sp_b with jcap,imax,jmax=',& + sp_b%jcap,sp_b%imax,sp_b%jmax endif inner_vars=1 - num_fields=min(8*grd_a%nsig+2,npe) -! Create temporary communication information fore read routines + num_fields=min(8*grd_a%nsig+2,npe) +! Create temporary communication information fore read routines call general_sub2grid_create_info(grd_t,inner_vars,grd_a%nlat,grd_a%nlon, & - grd_a%nsig,num_fields,regional) + grd_a%nsig,num_fields,regional) ! Allocate bundle used for reading members call gsi_gridcreate(atm_grid,lat2,lon2,nsig) call gsi_bundlecreate(atm_bundle,atm_grid,'aux-atm-read',istatus,names2d=vars2d,names3d=vars3d) if(istatus/=0) then - write(6,*)' read_gfs: trouble creating atm_bundle' - call stop2(999) + write(6,*)' read_gfs: trouble creating atm_bundle' + call stop2(999) endif zflag=.true. @@ -191,7 +191,7 @@ subroutine read_gfs if (hires_b) then ! If hires_b, spectral to grid transform for background -! uses double FFT. Need to pass in sp_a and sp_b +! uses double fft. Need to pass in sp_a and sp_b call general_read_gfsatm(grd_t,sp_a,sp_b,filename,.true.,.true.,zflag, & atm_bundle,& @@ -208,7 +208,7 @@ subroutine read_gfs inithead=.false. zflag=.false. -! Set values to actual MetGuess fields +! Set values to actual metguess fields call set_guess_ @@ -307,10 +307,10 @@ subroutine read_gfs_chem (iyear, month,idd, it ) ! ! prgrmmr: todling ! -! abstract: fills chemguess_bundle with GFS chemistry. +! abstract: fills chemguess_bundle with gfs chemistry. ! ! remarks: -! 1. Right now, only CO2 is done and even this is treated +! 1. Right now, only co2 is done and even this is treated ! as constant througout the assimialation window. ! 2. iyear and month could come from obsmod, but logically ! this program should never depend on obsmod @@ -318,13 +318,13 @@ subroutine read_gfs_chem (iyear, month,idd, it ) ! ! program history log: ! 2010-04-15 hou - Initial code -! 2010-05-19 todling - Port Hou's code from compute_derived(!) +! 2010-05-19 todling - Port hou's code from compute_derived(!) ! into this module and linked with the chemguess_bundle ! 2011-02-01 r. yang - proper initialization of prsi ! 2011-05-24 yang - add idd for time interpolation of co2 field ! 2011-06-29 todling - no explict reference to internal bundle arrays -! 2013-11-08 todling - revisit check for present of GHG in chem-bundle -! 2016-01-12 todling - allow for full Co2 field to be used when specified by user +! 2013-11-08 todling - revisit check for present of ghg in chem-bundle +! 2016-01-12 todling - allow for full co2 field to be used when specified by user ! (should be extra option in ncepgfs_ghg) ! - pass time index (it) as optional arg for when routine ! called sequentially in time @@ -386,10 +386,10 @@ subroutine read_gfs_chem (iyear, month,idd, it ) n = min(max(1, istart(j)+i-2), nlat) xlats(i) = rlats(n) enddo -!!NOTE: NEED TO CHANGE THIS BLOCK, THE CHECK AND READ OF TRACE GASES ARE HARDWIRED !!!!!! -!! WILL CHANGE THE CODE FOLLOWING WHAT I DID IN crtm_interface.f90 !!!!!! +!! Note: Need to change this block, the check and read of trace gases are hardwired !!!!!! +!! Will change the code following what I did in crtm_interface.f90 !!!!!! -! check whether CO2 exist +! check whether co2 exist call gsi_bundlegetpointer(gsi_chemguess_bundle(it_),'co2',p_co2,ier) if (associated(p_co2)) then call gsi_chemguess_get ( 'i4crtm::co2', ico24crtm, ier ) @@ -398,7 +398,7 @@ subroutine read_gfs_chem (iyear, month,idd, it ) call read_gfsco2 (iyear,month,idd,ico24crtm,xlats,& lat2,lon2,nsig,mype, & p_co2 ) -! Approximation: assign three time slots (nfldsig) of ghg with same values +! Approximation: assign three time slots (nfldsig) of ghg with same values if (.not.present(it)) then do n=2,nfldsig call gsi_bundlegetpointer(gsi_chemguess_bundle(n),'co2',ptr3d_co2,ier) @@ -417,12 +417,12 @@ subroutine read_gfs_chem (iyear, month,idd, it ) deallocate(avefld) endif char_ghg='co2' -! take comment out for printing out the interpolated tracer gas fields. -! call write_ghg_grid (ptr3d_co2,char_ghg) +! take comment out for printing out the interpolated tracer gas fields. +! call write_ghg_grid (ptr3d_co2,char_ghg) endif endif ! -! check whether CH4 data exist +! check whether ch4 data exist call gsi_bundlegetpointer(gsi_chemguess_bundle(it_),'ch4',p_ch4,ier) if (associated(p_ch4)) then call gsi_chemguess_get ( 'i4crtm::ch4', ich44crtm, ier ) @@ -437,12 +437,12 @@ subroutine read_gfs_chem (iyear, month,idd, it ) ptr3d_ch4 = p_ch4 enddo endif -! take comment out for printing out the interpolated tracer gas fields. +! take comment out for printing out the interpolated tracer gas fields. ! call write_ghg_grid (ptr3d_ch4,char_ghg) endif endif ! -! check whether N2O data exist +! check whether n2o data exist call gsi_bundlegetpointer(gsi_chemguess_bundle(it_),'n2o',p_n2o,ier) if (associated(p_n2o)) then call gsi_chemguess_get ( 'i4crtm::n2o', in2o4crtm, ier ) @@ -457,12 +457,12 @@ subroutine read_gfs_chem (iyear, month,idd, it ) ptr3d_n2o = p_n2o enddo endif -! take comment out for printing out the interpolated tracer gas fields. -! call write_ghg_grid (ptr3d_n2o,char_ghg) +! take comment out for printing out the interpolated tracer gas fields. +! call write_ghg_grid (ptr3d_n2o,char_ghg) endif endif ! -! check whether CO data exist +! check whether co data exist call gsi_bundlegetpointer(gsi_chemguess_bundle(it_),'co',p_co,ier) if (associated(p_co)) then call gsi_chemguess_get ( 'i4crtm::co', ico4crtm, ier ) @@ -477,12 +477,12 @@ subroutine read_gfs_chem (iyear, month,idd, it ) ptr3d_co = p_co enddo endif -! take comment out for printing out the interpolated tracer gas fields. -! call write_ghg_grid (ptr3d_co,char_ghg) +! take comment out for printing out the interpolated tracer gas fields. +! call write_ghg_grid (ptr3d_co,char_ghg) endif endif ! end subroutine read_gfs_chem -subroutine write_ghg_grid(a,char_ghg) + subroutine write_ghg_grid(a,char_ghg) !$$$ subroutine documentation block ! ! subprogram: write_ghg_grid @@ -499,48 +499,48 @@ subroutine write_ghg_grid(a,char_ghg) ! machine: ! !$$$ - use mpimod, only: mype - use kinds, only: r_kind,i_kind,r_single - use gridmod, only: nlat,nlon,nsig,lat2,lon2 - use file_utility, only : get_lun - implicit none + use mpimod, only: mype + use kinds, only: r_kind,i_kind,r_single + use gridmod, only: nlat,nlon,nsig,lat2,lon2 + use file_utility, only : get_lun + implicit none + + real(r_kind),dimension(lat2,lon2,nsig),intent(in ) :: a + character(len=3),intent(in) :: char_ghg + + character(255):: grdfile + + real(r_kind),dimension(nlat,nlon,nsig):: ag + + real(r_single),dimension(nlon,nlat,nsig):: a4 + integer(i_kind) ncfggg,iret,i,j,k,lu + +! gather stuff to processor 0 + do k=1,nsig + call gather_stuff2(a(1,1,k),ag(1,1,k),mype,0) + end do + if (mype==0) then + write(6,*) 'WRITE OUT INTERPOLATED ',char_ghg +! load single precision arrays + do k=1,nsig + do j=1,nlon + do i=1,nlat + a4(j,i,k)=ag(i,j,k) + end do + end do + end do + +! Create byte-addressable binary file for grads + grdfile=trim(char_ghg)//'clim_grd' + ncfggg=len_trim(grdfile) + lu=get_lun() + call baopenwt(lu,grdfile(1:ncfggg),iret) + call wryte(lu,4*nlat*nlon*nsig,a4) + call baclose(lu,iret) + end if - real(r_kind),dimension(lat2,lon2,nsig),intent(in ) :: a - character(len=3),intent(in) :: char_ghg - - character(255):: grdfile - - real(r_kind),dimension(nlat,nlon,nsig):: ag - - real(r_single),dimension(nlon,nlat,nsig):: a4 - integer(i_kind) ncfggg,iret,i,j,k,lu - -! gather stuff to processor 0 - do k=1,nsig - call gather_stuff2(a(1,1,k),ag(1,1,k),mype,0) - end do - if (mype==0) then - write(6,*) 'WRITE OUT INTERPOLATED ',char_ghg -! load single precision arrays - do k=1,nsig - do j=1,nlon - do i=1,nlat - a4(j,i,k)=ag(i,j,k) - end do - end do - end do - -! Create byte-addressable binary file for grads - grdfile=trim(char_ghg)//'clim_grd' - ncfggg=len_trim(grdfile) - lu=get_lun() - call baopenwt(lu,grdfile(1:ncfggg),iret) - call wryte(lu,4*nlat*nlon*nsig,a4) - call baclose(lu,iret) - end if - - return -end subroutine write_ghg_grid + return + end subroutine write_ghg_grid subroutine read_sfc(sfct,soil_moi,sno,soil_temp,veg_frac,fact10,sfc_rough, & veg_type,soil_type,terrain,isli,use_sfc_any) @@ -550,7 +550,7 @@ subroutine read_sfc(sfct,soil_moi,sno,soil_temp,veg_frac,fact10,sfc_rough, & ! ! prgrmmr: whitaker ! -! abstract: read a ncep GFS surface file on a specified task, +! abstract: read a ncep gfs surface file on a specified task, ! broadcast data to other tasks. ! ! program history log: @@ -583,6 +583,7 @@ subroutine read_sfc(sfct,soil_moi,sno,soil_temp,veg_frac,fact10,sfc_rough, & use kinds, only: i_kind,r_single,r_kind use gridmod, only: nlat_sfc,nlon_sfc use guess_grids, only: nfldsfc,ifilesfc + implicit none logical, intent(in ) :: use_sfc_any real(r_single), dimension(nlat_sfc,nlon_sfc,nfldsfc), intent( out) :: sfct,soil_moi,sno,soil_temp,veg_frac,fact10,sfc_rough @@ -600,7 +601,7 @@ subroutine read_sfc(sfct,soil_moi,sno,soil_temp,veg_frac,fact10,sfc_rough, & integer(i_kind),parameter:: nsfc_all = 11 do it=1,nfldsfc -! read a surface file on the task +! read a surface file on the task write(filename,200)ifilesfc(it) 200 format('sfcf',i2.2) call sfcio_srohdc(lunges,filename,sfc_head,sfc_data,iret) @@ -614,16 +615,16 @@ subroutine read_sfc(sfct,soil_moi,sno,soil_temp,veg_frac,fact10,sfc_rough, & lonb = sfc_head%lonb latb = sfc_head%latb if ( (latb /= nlat_sfc-2) .or. (lonb /= nlon_sfc) ) then - write(6,*)'READ_GFSSFC: ***ERROR*** inconsistent grid dimensions. ',& - ', nlon,nlat-2=',nlon_sfc,nlat_sfc-2,' -vs- sfc file lonb,latb=',& - lonb,latb - call sfcio_axdata(sfc_data,iret) - call stop2(80) + write(6,*)'READ_GFSSFC: ***ERROR*** inconsistent grid dimensions. ',& + ', nlon,nlat-2=',nlon_sfc,nlat_sfc-2,' -vs- sfc file lonb,latb=',& + lonb,latb + call sfcio_axdata(sfc_data,iret) + call stop2(80) endif if(it == 1)then - nsfc=nsfc_all + nsfc=nsfc_all else - nsfc=nsfc_all-4 + nsfc=nsfc_all-4 end if !$omp parallel do private(n,i,j,outtmp) do n = 1, nsfc @@ -683,7 +684,7 @@ subroutine read_sfc(sfct,soil_moi,sno,soil_temp,veg_frac,fact10,sfc_rough, & ! End of loop over data records enddo -! Print date/time stamp +! Print date/time stamp write(6,700) latb,lonb,sfc_head%fhour,sfc_head%idate 700 format('READ_SFC: ges read/scatter, nlat,nlon=',& 2i6,', hour=',f10.1,', idate=',4i5) @@ -763,7 +764,7 @@ subroutine read_gfssfc(iope,sfct,soil_moi,sno,soil_temp,veg_frac,fact10,sfc_roug veg_type,soil_type,terrain,isli,use_sfc_any) end if -! Load onto all processors +! Load onto all processors npts=nlat_sfc*nlon_sfc nptsall=npts*nfldsfc @@ -796,7 +797,7 @@ subroutine read_sfc_anl(isli_anl) ! ! prgrmmr: li ! -! abstract: read a ncep GFS surface file with analysis grids resolution on a specified task, +! abstract: read a ncep gfs surface file with analysis grids resolution on a specified task, ! broadcast data to other tasks. Currently, isli only. ! ! program history log: @@ -816,6 +817,7 @@ subroutine read_sfc_anl(isli_anl) use sfcio_module, only: sfcio_axdata,sfcio_sclose use kinds, only: i_kind,r_single,r_kind use gridmod, only: nlat,nlon + implicit none integer(i_kind), dimension(nlat,nlon), intent( out) :: isli_anl integer(i_kind) :: latb,lonb @@ -827,7 +829,7 @@ subroutine read_sfc_anl(isli_anl) ! Declare local parameters integer(sfcio_intkind):: lunanl = 21 -! read a surface file with analysis resolution on the task : isli only currently +! read a surface file with analysis resolution on the task : isli only currently filename='sfcf06_anlgrid' call sfcio_srohdc(lunanl,trim(filename),sfc_head,sfc_data,iret) ! Check for possible problems @@ -840,11 +842,11 @@ subroutine read_sfc_anl(isli_anl) lonb = sfc_head%lonb latb = sfc_head%latb if ( (latb /= nlat-2) .or. (lonb /= nlon) ) then - write(6,*)'READ_SFC_ANL: ***ERROR*** inconsistent grid dimensions. ',& - ', nlon,nlat-2=',nlon,nlat-2,' -vs- sfc file lonb,latb=',& - lonb,latb - call sfcio_axdata(sfc_data,iret) - call stop2(80) + write(6,*)'READ_SFC_ANL: ***ERROR*** inconsistent grid dimensions. ',& + ', nlon,nlat-2=',nlon,nlat-2,' -vs- sfc file lonb,latb=',& + lonb,latb + call sfcio_axdata(sfc_data,iret) + call stop2(80) endif allocate(outtmp(latb+2,lonb)) @@ -927,7 +929,7 @@ subroutine read_nst(tref,dt_cool,z_c,dt_warm,z_w,c_0,c_d,w_0,w_d) ! 2015-04-24 li - create routine based on read_sfc ! ! input argument list: -! lunges - unit number to use for IO +! lunges - unit number to use for io ! filename - nst surface file to read ! ! output argument list: @@ -943,6 +945,8 @@ subroutine read_nst(tref,dt_cool,z_c,dt_warm,z_w,c_0,c_d,w_0,w_d) use gridmod, only: nlat_sfc,nlon_sfc use guess_grids, only: nfldnst,ifilenst use constants, only: two + implicit none + real(r_single), dimension(nlat_sfc,nlon_sfc,nfldnst),intent( out) :: & tref,dt_cool,z_c,dt_warm,z_w,c_0,c_d,w_0,w_d integer(i_kind) :: latb,lonb @@ -957,7 +961,7 @@ subroutine read_nst(tref,dt_cool,z_c,dt_warm,z_w,c_0,c_d,w_0,w_d) integer(i_kind),parameter:: nnst_all = 9 do it=1,nfldnst -! read a nst file on the task +! read a nst file on the task write(filename,200)ifilenst(it) 200 format('nstf',i2.2) call nstio_srohdc(lunges,filename,nst_head,nst_data,iret) @@ -983,7 +987,7 @@ subroutine read_nst(tref,dt_cool,z_c,dt_warm,z_w,c_0,c_d,w_0,w_d) !$omp parallel do private(n,dwarm_tmp) do n=1,nnst - if(n == 1)then ! foundation temperature (Tf) + if(n == 1)then ! foundation temperature (tf) call tran_gfssfc(nst_data%tref,tref(1,1,it),lonb,latb) @@ -1006,19 +1010,19 @@ subroutine read_nst(tref,dt_cool,z_c,dt_warm,z_w,c_0,c_d,w_0,w_d) call tran_gfssfc(nst_data%xz,z_w(1,1,it),lonb,latb) - else if(n == 6) then ! coefficient 1 to get d(Tz)/d(Tf) + else if(n == 6) then ! coefficient 1 to get d(tz)/d(tf) call tran_gfssfc(nst_data%c_0,c_0(1,1,it),lonb,latb) - else if(n == 7) then ! coefficient 2 to get d(Tz)/d(Tf) + else if(n == 7) then ! coefficient 2 to get d(tz)/d(tf) call tran_gfssfc(nst_data%c_d,c_d(1,1,it),lonb,latb) - else if(n == 8 ) then ! coefficient 3 to get d(Tz)/d(Tf) + else if(n == 8 ) then ! coefficient 3 to get d(tz)/d(tf) call tran_gfssfc(nst_data%w_0,w_0(1,1,it),lonb,latb) - else if(n == 9 ) then ! coefficient 4 to get d(Tz)/d(Tf) + else if(n == 9 ) then ! coefficient 4 to get d(tz)/d(tf) call tran_gfssfc(nst_data%w_d,w_d(1,1,it),lonb,latb) @@ -1026,13 +1030,13 @@ subroutine read_nst(tref,dt_cool,z_c,dt_warm,z_w,c_0,c_d,w_0,w_d) ! End of loop over data records end do -! Print date/time stamp +! Print date/time stamp write(6,700) latb,lonb,nst_head%fhour,nst_head%idate 700 format('READ_NST: ges read/scatter, nlat,nlon=',& 2i6,', hour=',f10.1,', idate=',4i5) call nstio_axdata(nst_data,iret) call nstio_srclose(lunges,iret) -! End of loop over time levels +! End of loop over time levels end do end subroutine read_nst @@ -1049,7 +1053,7 @@ subroutine read_gfsnst(iope,tref,dt_cool,z_c,dt_warm,z_w,c_0,c_d,w_0,w_d) ! ! ! program history log: -! 2015-04-25 li : modify to minimize communications/IO +! 2015-04-25 li : modify to minimize communications/io ! ! input argument list: ! iope - mpi task handling i/o @@ -1060,10 +1064,10 @@ subroutine read_gfsnst(iope,tref,dt_cool,z_c,dt_warm,z_w,c_0,c_d,w_0,w_d) ! z_c (:,:) ! depth of sub-layer cooling layer ! dt_warm (:,:) ! diurnal warming amount at sea surface (skin layer) ! z_w (:,:) ! depth of diurnal warming layer -! c_0 (:,:) ! coefficient to calculate d(Tz)/d(tr) in dimensionless -! c_d (:,:) ! coefficient to calculate d(Tz)/d(tr) in m^-1 -! w_0 (:,:) ! coefficient to calculate d(Tz)/d(tr) in dimensionless -! w_d (:,:) ! coefficient to calculate d(Tz)/d(tr) in m^-1 +! c_0 (:,:) ! coefficient to calculate d(tz)/d(tr) in dimensionless +! c_d (:,:) ! coefficient to calculate d(tz)/d(tr) in m^-1 +! w_0 (:,:) ! coefficient to calculate d(tz)/d(tr) in dimensionless +! w_d (:,:) ! coefficient to calculate d(tz)/d(tr) in m^-1 ! ! attributes: ! language: f90 @@ -1089,7 +1093,7 @@ subroutine read_gfsnst(iope,tref,dt_cool,z_c,dt_warm,z_w,c_0,c_d,w_0,w_d) !----------------------------------------------------------------------------- ! Read nst file on processor iope if(mype == iope)then - call read_nst(tref,dt_cool,z_c,dt_warm,z_w,c_0,c_d,w_0,w_d) + call read_nst(tref,dt_cool,z_c,dt_warm,z_w,c_0,c_d,w_0,w_d) end if ! Load onto all processors @@ -1132,12 +1136,12 @@ subroutine write_gfs(increment,mype_atm,mype_sfc) ! where cw increments are calculated with nonnegative cw ! gues while original cw gues still have negative values. ! 2013-10-19 todling - update cloud_efr module name -! 2013-10-29 todling - revisit write to allow skipping vars not in MetGuess -! 2018-05-19 eliu - add I/O for fv3 hydrometeors +! 2013-10-29 todling - revisit write to allow skipping vars not in metguess +! 2018-05-19 eliu - add i/o for fv3 hydrometeors ! 2019-03-21 Wei/Martin - write out global aerosol arrays if needed ! 2019-09-04 martin - added option to write fv3 netcdf increment file ! 2019-09-24 martin - added logic for when use_gfs_ncio is true, note -! writing netCDF analysis for GFS not currently supported +! writing netcdf analysis for gfs not currently supported ! ! input argument list: ! increment - when >0 will write increment from increment-index slot @@ -1220,20 +1224,20 @@ subroutine write_gfs(increment,mype_atm,mype_sfc) real(r_kind),pointer,dimension(:,:,:):: aux_du1,aux_du2,aux_du3,aux_du4,aux_du5 real(r_kind),pointer,dimension(:,:,:):: aux_ss1,aux_ss2,aux_ss3,aux_ss4,aux_so4 real(r_kind),pointer,dimension(:,:,:):: aux_oc1,aux_oc2,aux_bc1,aux_bc2 - real(r_kind),pointer,dimension(:,:,:):: ges_du1_it=>NULL() - real(r_kind),pointer,dimension(:,:,:):: ges_du2_it=>NULL() - real(r_kind),pointer,dimension(:,:,:):: ges_du3_it=>NULL() - real(r_kind),pointer,dimension(:,:,:):: ges_du4_it=>NULL() - real(r_kind),pointer,dimension(:,:,:):: ges_du5_it=>NULL() - real(r_kind),pointer,dimension(:,:,:):: ges_ss1_it=>NULL() - real(r_kind),pointer,dimension(:,:,:):: ges_ss2_it=>NULL() - real(r_kind),pointer,dimension(:,:,:):: ges_ss3_it=>NULL() - real(r_kind),pointer,dimension(:,:,:):: ges_ss4_it=>NULL() - real(r_kind),pointer,dimension(:,:,:):: ges_so4_it=>NULL() - real(r_kind),pointer,dimension(:,:,:):: ges_oc1_it=>NULL() - real(r_kind),pointer,dimension(:,:,:):: ges_oc2_it=>NULL() - real(r_kind),pointer,dimension(:,:,:):: ges_bc1_it=>NULL() - real(r_kind),pointer,dimension(:,:,:):: ges_bc2_it=>NULL() + real(r_kind),pointer,dimension(:,:,:):: ges_du1_it=>null() + real(r_kind),pointer,dimension(:,:,:):: ges_du2_it=>null() + real(r_kind),pointer,dimension(:,:,:):: ges_du3_it=>null() + real(r_kind),pointer,dimension(:,:,:):: ges_du4_it=>null() + real(r_kind),pointer,dimension(:,:,:):: ges_du5_it=>null() + real(r_kind),pointer,dimension(:,:,:):: ges_ss1_it=>null() + real(r_kind),pointer,dimension(:,:,:):: ges_ss2_it=>null() + real(r_kind),pointer,dimension(:,:,:):: ges_ss3_it=>null() + real(r_kind),pointer,dimension(:,:,:):: ges_ss4_it=>null() + real(r_kind),pointer,dimension(:,:,:):: ges_so4_it=>null() + real(r_kind),pointer,dimension(:,:,:):: ges_oc1_it=>null() + real(r_kind),pointer,dimension(:,:,:):: ges_oc2_it=>null() + real(r_kind),pointer,dimension(:,:,:):: ges_bc1_it=>null() + real(r_kind),pointer,dimension(:,:,:):: ges_bc2_it=>null() type(gsi_bundle) :: chem_bundle type(gsi_bundle) :: atm_bundle type(gsi_grid) :: atm_grid @@ -1263,8 +1267,8 @@ subroutine write_gfs(increment,mype_atm,mype_sfc) call gsi_gridcreate(atm_grid,grd_a%lat2,grd_a%lon2,grd_a%nsig) call gsi_bundlecreate(atm_bundle,atm_grid,'aux-atm-write',istatus,names2d=vars2d,names3d=vars3d) if ( istatus /= 0 ) then - write(6,*)' write_gfs: trouble creating atm_bundle' - call stop2(999) + write(6,*)' write_gfs: trouble creating atm_bundle' + call stop2(999) endif call gsi_bundlegetpointer(atm_bundle,'ps',aux_ps,istatus) @@ -1338,195 +1342,195 @@ subroutine write_gfs(increment,mype_atm,mype_sfc) inithead=.true. do it=1,ntlevs - if ( lwrite4danl ) then - ! check to see if we want to output this time. - ! if not, skip to next time - if (count(nhr_anal/=0)>0) then - if (count(nhr_anal==ifilesig(it))==0) cycle - endif - itoutsig = it - if ( it == ntguessig ) then - if ( increment > 0 .or. write_fv3_incr ) then - filename = 'siginc' - else - filename = 'siganl' - endif - else - if ( increment > 0 .or. write_fv3_incr ) then - write(filename,"('sigi',i2.2)") ifilesig(it) - else - write(filename,"('siga',i2.2)") ifilesig(it) - endif - endif - else - itoutsig = ntguessig - if ( increment > 0 .or. write_fv3_incr ) then + if ( lwrite4danl ) then + ! check to see if we want to output this time. + ! if not, skip to next time + if (count(nhr_anal/=0)>0) then + if (count(nhr_anal==ifilesig(it))==0) cycle + endif + itoutsig = it + if ( it == ntguessig ) then + if ( increment > 0 .or. write_fv3_incr ) then filename = 'siginc' - else + else filename = 'siganl' - endif - endif - - if ( mype == 0 ) then - if ( increment > 0 .or. write_fv3_incr ) then - write(6,'(A,I2.2)') 'WRITE_GFS: writing analysis increment for FHR ', ifilesig(itoutsig) - else - write(6,'(A,I2.2)') 'WRITE_GFS: writing full analysis state for FHR ', ifilesig(itoutsig) - endif - endif + endif + else + if ( increment > 0 .or. write_fv3_incr ) then + write(filename,"('sigi',i2.2)") ifilesig(it) + else + write(filename,"('siga',i2.2)") ifilesig(it) + endif + endif + else + itoutsig = ntguessig + if ( increment > 0 .or. write_fv3_incr ) then + filename = 'siginc' + else + filename = 'siganl' + endif + endif + + if ( mype == 0 ) then + if ( increment > 0 .or. write_fv3_incr ) then + write(6,'(A,I2.2)') 'WRITE_GFS: writing analysis increment for FHR ', ifilesig(itoutsig) + else + write(6,'(A,I2.2)') 'WRITE_GFS: writing full analysis state for FHR ', ifilesig(itoutsig) + endif + endif - call gsi_bundlegetpointer (gsi_metguess_bundle(itoutsig),'ps',ges_ps_it ,istatus) - if ( istatus == 0 ) aux_ps = ges_ps_it - call gsi_bundlegetpointer (gsi_metguess_bundle(itoutsig),'u' ,ges_u_it ,istatus) - if ( istatus == 0 ) aux_u = ges_u_it - call gsi_bundlegetpointer (gsi_metguess_bundle(itoutsig),'v' ,ges_v_it ,istatus) - if ( istatus == 0 ) aux_v = ges_v_it - call gsi_bundlegetpointer (gsi_metguess_bundle(itoutsig),'vor',ges_vor_it,istatus) - if ( istatus == 0 ) aux_vor = ges_vor_it - call gsi_bundlegetpointer (gsi_metguess_bundle(itoutsig),'div',ges_div_it,istatus) - if ( istatus == 0 ) aux_div = ges_div_it - call gsi_bundlegetpointer (gsi_metguess_bundle(itoutsig),'tv',ges_tv_it ,istatus) - if ( istatus == 0 ) aux_tv = ges_tv_it - call gsi_bundlegetpointer (gsi_metguess_bundle(itoutsig),'q' ,ges_q_it ,istatus) - if ( istatus == 0 ) aux_q = ges_q_it - call gsi_bundlegetpointer (gsi_metguess_bundle(itoutsig),'oz',ges_oz_it ,istatus) - if ( istatus == 0 ) aux_oz = ges_oz_it - call gsi_bundlegetpointer (gsi_metguess_bundle(itoutsig),'ql',ges_ql_it,istatus) - if ( istatus == 0 ) aux_ql = ges_ql_it - call gsi_bundlegetpointer (gsi_metguess_bundle(itoutsig),'qi',ges_qi_it,istatus) - if ( istatus == 0 ) aux_qi = ges_qi_it - call gsi_bundlegetpointer (gsi_metguess_bundle(itoutsig),'qr',ges_qr_it,istatus) - if ( istatus == 0 ) aux_qr = ges_qr_it - call gsi_bundlegetpointer (gsi_metguess_bundle(itoutsig),'qs',ges_qs_it,istatus) - if ( istatus == 0 ) aux_qs = ges_qs_it - call gsi_bundlegetpointer (gsi_metguess_bundle(itoutsig),'qg',ges_qg_it,istatus) - if ( istatus == 0 ) aux_qg = ges_qg_it - call gsi_bundlegetpointer (gsi_metguess_bundle(itoutsig),'cf',ges_cf_it,istatus) - if ( istatus == 0 ) aux_cf = ges_cf_it - call gsi_bundlegetpointer (gsi_metguess_bundle(itoutsig),'cw',ges_cwmr_it,istatus) - if ( istatus == 0 ) aux_cwmr = ges_cwmr_it - -! if aerosols, get the data from chem bundle to output - if ( laeroana_gocart ) then - call gsi_bundlegetpointer(gsi_chemguess_bundle(itoutsig),'dust1',ges_du1_it,istatus) - if( istatus==0 ) aux_du1 = ges_du1_it - call gsi_bundlegetpointer(gsi_chemguess_bundle(itoutsig),'dust2',ges_du2_it,istatus) - if( istatus==0 ) aux_du2 = ges_du2_it - call gsi_bundlegetpointer(gsi_chemguess_bundle(itoutsig),'dust3',ges_du3_it,istatus) - if( istatus==0 ) aux_du3 = ges_du3_it - call gsi_bundlegetpointer(gsi_chemguess_bundle(itoutsig),'dust4',ges_du4_it,istatus) - if( istatus==0 ) aux_du4 = ges_du4_it - call gsi_bundlegetpointer(gsi_chemguess_bundle(itoutsig),'dust5',ges_du5_it,istatus) - if( istatus==0 ) aux_du5 = ges_du5_it - call gsi_bundlegetpointer(gsi_chemguess_bundle(itoutsig),'seas1',ges_ss1_it,istatus) - if( istatus==0 ) aux_ss1 = ges_ss1_it - call gsi_bundlegetpointer(gsi_chemguess_bundle(itoutsig),'seas2',ges_ss2_it,istatus) - if( istatus==0 ) aux_ss2 = ges_ss2_it - call gsi_bundlegetpointer(gsi_chemguess_bundle(itoutsig),'seas3',ges_ss3_it,istatus) - if( istatus==0 ) aux_ss3 = ges_ss3_it - call gsi_bundlegetpointer(gsi_chemguess_bundle(itoutsig),'seas4',ges_ss4_it,istatus) - if( istatus==0 ) aux_ss4 = ges_ss4_it - call gsi_bundlegetpointer (gsi_chemguess_bundle(itoutsig),'sulf',ges_so4_it,istatus) - if( istatus==0 ) aux_so4 = ges_so4_it - call gsi_bundlegetpointer (gsi_chemguess_bundle(itoutsig),'oc1',ges_oc1_it,istatus) - if( istatus==0 ) aux_oc1 = ges_oc1_it - call gsi_bundlegetpointer (gsi_chemguess_bundle(itoutsig),'oc2',ges_oc2_it,istatus) - if( istatus==0 ) aux_oc2 = ges_oc2_it - call gsi_bundlegetpointer (gsi_chemguess_bundle(itoutsig),'bc1',ges_bc1_it,istatus) - if( istatus==0 ) aux_bc1 = ges_bc1_it - call gsi_bundlegetpointer (gsi_chemguess_bundle(itoutsig),'bc2',ges_bc2_it,istatus) - if( istatus==0 ) aux_bc2 = ges_bc2_it - end if ! laeroana_gocart - if ( use_gfs_nemsio ) then - - if ( write_fv3_incr ) then - call write_fv3_increment(grd_a,sp_a,filename,mype_atm, & + call gsi_bundlegetpointer (gsi_metguess_bundle(itoutsig),'ps',ges_ps_it ,istatus) + if ( istatus == 0 ) aux_ps = ges_ps_it + call gsi_bundlegetpointer (gsi_metguess_bundle(itoutsig),'u' ,ges_u_it ,istatus) + if ( istatus == 0 ) aux_u = ges_u_it + call gsi_bundlegetpointer (gsi_metguess_bundle(itoutsig),'v' ,ges_v_it ,istatus) + if ( istatus == 0 ) aux_v = ges_v_it + call gsi_bundlegetpointer (gsi_metguess_bundle(itoutsig),'vor',ges_vor_it,istatus) + if ( istatus == 0 ) aux_vor = ges_vor_it + call gsi_bundlegetpointer (gsi_metguess_bundle(itoutsig),'div',ges_div_it,istatus) + if ( istatus == 0 ) aux_div = ges_div_it + call gsi_bundlegetpointer (gsi_metguess_bundle(itoutsig),'tv',ges_tv_it ,istatus) + if ( istatus == 0 ) aux_tv = ges_tv_it + call gsi_bundlegetpointer (gsi_metguess_bundle(itoutsig),'q' ,ges_q_it ,istatus) + if ( istatus == 0 ) aux_q = ges_q_it + call gsi_bundlegetpointer (gsi_metguess_bundle(itoutsig),'oz',ges_oz_it ,istatus) + if ( istatus == 0 ) aux_oz = ges_oz_it + call gsi_bundlegetpointer (gsi_metguess_bundle(itoutsig),'ql',ges_ql_it,istatus) + if ( istatus == 0 ) aux_ql = ges_ql_it + call gsi_bundlegetpointer (gsi_metguess_bundle(itoutsig),'qi',ges_qi_it,istatus) + if ( istatus == 0 ) aux_qi = ges_qi_it + call gsi_bundlegetpointer (gsi_metguess_bundle(itoutsig),'qr',ges_qr_it,istatus) + if ( istatus == 0 ) aux_qr = ges_qr_it + call gsi_bundlegetpointer (gsi_metguess_bundle(itoutsig),'qs',ges_qs_it,istatus) + if ( istatus == 0 ) aux_qs = ges_qs_it + call gsi_bundlegetpointer (gsi_metguess_bundle(itoutsig),'qg',ges_qg_it,istatus) + if ( istatus == 0 ) aux_qg = ges_qg_it + call gsi_bundlegetpointer (gsi_metguess_bundle(itoutsig),'cf',ges_cf_it,istatus) + if ( istatus == 0 ) aux_cf = ges_cf_it + call gsi_bundlegetpointer (gsi_metguess_bundle(itoutsig),'cw',ges_cwmr_it,istatus) + if ( istatus == 0 ) aux_cwmr = ges_cwmr_it + +! if aerosols, get the data from chem bundle to output + if ( laeroana_gocart ) then + call gsi_bundlegetpointer(gsi_chemguess_bundle(itoutsig),'dust1',ges_du1_it,istatus) + if( istatus==0 ) aux_du1 = ges_du1_it + call gsi_bundlegetpointer(gsi_chemguess_bundle(itoutsig),'dust2',ges_du2_it,istatus) + if( istatus==0 ) aux_du2 = ges_du2_it + call gsi_bundlegetpointer(gsi_chemguess_bundle(itoutsig),'dust3',ges_du3_it,istatus) + if( istatus==0 ) aux_du3 = ges_du3_it + call gsi_bundlegetpointer(gsi_chemguess_bundle(itoutsig),'dust4',ges_du4_it,istatus) + if( istatus==0 ) aux_du4 = ges_du4_it + call gsi_bundlegetpointer(gsi_chemguess_bundle(itoutsig),'dust5',ges_du5_it,istatus) + if( istatus==0 ) aux_du5 = ges_du5_it + call gsi_bundlegetpointer(gsi_chemguess_bundle(itoutsig),'seas1',ges_ss1_it,istatus) + if( istatus==0 ) aux_ss1 = ges_ss1_it + call gsi_bundlegetpointer(gsi_chemguess_bundle(itoutsig),'seas2',ges_ss2_it,istatus) + if( istatus==0 ) aux_ss2 = ges_ss2_it + call gsi_bundlegetpointer(gsi_chemguess_bundle(itoutsig),'seas3',ges_ss3_it,istatus) + if( istatus==0 ) aux_ss3 = ges_ss3_it + call gsi_bundlegetpointer(gsi_chemguess_bundle(itoutsig),'seas4',ges_ss4_it,istatus) + if( istatus==0 ) aux_ss4 = ges_ss4_it + call gsi_bundlegetpointer (gsi_chemguess_bundle(itoutsig),'sulf',ges_so4_it,istatus) + if( istatus==0 ) aux_so4 = ges_so4_it + call gsi_bundlegetpointer (gsi_chemguess_bundle(itoutsig),'oc1',ges_oc1_it,istatus) + if( istatus==0 ) aux_oc1 = ges_oc1_it + call gsi_bundlegetpointer (gsi_chemguess_bundle(itoutsig),'oc2',ges_oc2_it,istatus) + if( istatus==0 ) aux_oc2 = ges_oc2_it + call gsi_bundlegetpointer (gsi_chemguess_bundle(itoutsig),'bc1',ges_bc1_it,istatus) + if( istatus==0 ) aux_bc1 = ges_bc1_it + call gsi_bundlegetpointer (gsi_chemguess_bundle(itoutsig),'bc2',ges_bc2_it,istatus) + if( istatus==0 ) aux_bc2 = ges_bc2_it + end if ! laeroana_gocart + if ( use_gfs_nemsio ) then + + if ( write_fv3_incr ) then + call write_fv3_increment(grd_a,sp_a,filename,mype_atm, & + atm_bundle,itoutsig) + else + if (fv3_full_hydro) then + call write_fv3atm_nems(grd_a,sp_a,filename,mype_atm, & atm_bundle,itoutsig) - else - if (fv3_full_hydro) then - call write_fv3atm_nems(grd_a,sp_a,filename,mype_atm, & - atm_bundle,itoutsig) + else + ! if using aerosols, optional chem_bundle argument + if ( laeroana_gocart ) then + call write_nemsatm(grd_a,sp_a,filename,mype_atm, & + atm_bundle,itoutsig,chem_bundle) else - ! if using aerosols, optional chem_bundle argument - if ( laeroana_gocart ) then - call write_nemsatm(grd_a,sp_a,filename,mype_atm, & - atm_bundle,itoutsig,chem_bundle) - else ! otherwise, just atm_bundle - call write_nemsatm(grd_a,sp_a,filename,mype_atm, & - atm_bundle,itoutsig) - end if ! laeroana_gocart - endif - end if - - else if ( use_gfs_ncio ) then - if ( write_fv3_incr ) then - call write_fv3_increment(grd_a,sp_a,filename,mype_atm, & - atm_bundle,itoutsig) - else - call write_gfsncatm(grd_a,sp_a,filename,mype_atm, & - atm_bundle,itoutsig) - end if - else - - ! If hires_b, spectral to grid transform for background - ! uses double FFT. Need to pass in sp_a and sp_b - nlon_b=((2*jcap_b+1)/nlon+1)*nlon - if ( nlon_b /= sp_a%imax ) then - hires_b=.true. - call general_init_spec_vars(sp_b,jcap_b,jcap_b,nlat,nlon_b) - if ( mype == 0 ) & - write(6,*)'WRITE_GFS: allocate and load sp_b with jcap,imax,jmax=',& - sp_b%jcap,sp_b%imax,sp_b%jmax + call write_nemsatm(grd_a,sp_a,filename,mype_atm, & + atm_bundle,itoutsig) + end if ! laeroana_gocart + endif + end if + + else if ( use_gfs_ncio ) then + if ( write_fv3_incr ) then + call write_fv3_increment(grd_a,sp_a,filename,mype_atm, & + atm_bundle,itoutsig) + else + call write_gfsncatm(grd_a,sp_a,filename,mype_atm, & + atm_bundle,itoutsig) + end if + else + + ! If hires_b, spectral to grid transform for background + ! uses double fft. Need to pass in sp_a and sp_b + nlon_b=((2*jcap_b+1)/nlon+1)*nlon + if ( nlon_b /= sp_a%imax ) then + hires_b=.true. + call general_init_spec_vars(sp_b,jcap_b,jcap_b,nlat,nlon_b) + if ( mype == 0 ) & + write(6,*)'WRITE_GFS: allocate and load sp_b with jcap,imax,jmax=',& + sp_b%jcap,sp_b%imax,sp_b%jmax - call general_write_gfsatm(grd_a,sp_a,sp_b,filename,mype_atm, & - atm_bundle,itoutsig,inithead,iret_write) + call general_write_gfsatm(grd_a,sp_a,sp_b,filename,mype_atm, & + atm_bundle,itoutsig,inithead,iret_write) - call general_destroy_spec_vars(sp_b) - ! Otherwise, use standard transform. Use sp_a in place of sp_b. - else - call general_write_gfsatm(grd_a,sp_a,sp_a,filename,mype_atm, & - atm_bundle,itoutsig,inithead,iret_write) - endif + call general_destroy_spec_vars(sp_b) + ! Otherwise, use standard transform. Use sp_a in place of sp_b. + else + call general_write_gfsatm(grd_a,sp_a,sp_a,filename,mype_atm, & + atm_bundle,itoutsig,inithead,iret_write) + endif - endif + endif - inithead=.false. + inithead=.false. enddo ! end do over ntlevs ! Write surface analysis file if ( increment > 0 ) then - filename='sfcinc.gsi' - if ( use_gfs_nemsio ) then - call write_nemssfc(filename,mype_sfc,dsfct(:,:,ntguessfc)) - else if ( use_gfs_ncio ) then - call write_gfsncsfc(filename,mype_sfc,dsfct(:,:,ntguessfc)) - else - call write_gfssfc(filename,mype_sfc,dsfct(1,1,ntguessfc)) - endif + filename='sfcinc.gsi' + if ( use_gfs_nemsio ) then + call write_nemssfc(filename,mype_sfc,dsfct(:,:,ntguessfc)) + else if ( use_gfs_ncio ) then + call write_gfsncsfc(filename,mype_sfc,dsfct(:,:,ntguessfc)) + else + call write_gfssfc(filename,mype_sfc,dsfct(1,1,ntguessfc)) + endif else if ( nst_gsi > 0 ) then if ( sfcnst_comb ) then call write_tf_inc_nc(mype_sfc,dsfct(:,:,ntguessfc)) else if ( use_gfs_nemsio ) then - call write_nems_sfc_nst(mype_sfc,dsfct(:,:,ntguessfc)) + call write_nems_sfc_nst(mype_sfc,dsfct(:,:,ntguessfc)) else if ( use_gfs_ncio ) then - call write_gfsnc_sfc_nst(mype_sfc,dsfct(:,:,ntguessfc)) + call write_gfsnc_sfc_nst(mype_sfc,dsfct(:,:,ntguessfc)) else - call write_gfs_sfc_nst (mype_sfc,dsfct(1,1,ntguessfc)) + call write_gfs_sfc_nst (mype_sfc,dsfct(1,1,ntguessfc)) endif endif else - filename='sfcanl.gsi' - if ( use_gfs_nemsio ) then - call write_nemssfc(filename,mype_sfc,dsfct(:,:,ntguessfc)) - else if ( use_gfs_ncio ) then - call write_gfsncsfc(filename,mype_sfc,dsfct(:,:,ntguessfc)) - else - call write_gfssfc (filename,mype_sfc,dsfct(1,1,ntguessfc)) - endif + filename='sfcanl.gsi' + if ( use_gfs_nemsio ) then + call write_nemssfc(filename,mype_sfc,dsfct(:,:,ntguessfc)) + else if ( use_gfs_ncio ) then + call write_gfsncsfc(filename,mype_sfc,dsfct(:,:,ntguessfc)) + else + call write_gfssfc (filename,mype_sfc,dsfct(1,1,ntguessfc)) + endif endif endif @@ -1542,9 +1546,9 @@ subroutine write_gfssfc(filename,mype_sfc,dsfct) ! abstract: This routine writes the updated surface analysis. At ! this point (20040615) the only surface field update by ! the gsi is the skin temperature. The current (20040615) -! GDAS setup does use the updated surface file. Rather, +! gdas setup does use the updated surface file. Rather, ! the output from surface cycle is used as the surface -! analysis for subsequent GFS runs. +! analysis for subsequent gfs runs. ! ! The routine gathers surface fields from subdomains, ! reformats the data records, and then writes each record @@ -1554,7 +1558,7 @@ subroutine write_gfssfc(filename,mype_sfc,dsfct) ! other surface fields are simply read from the guess ! surface file and written to the analysis file. ! -! Structure of GFS surface file +! Structure of gfs surface file ! data record 1 label ! data record 2 date, dimension, version, lons/lat record ! data record 3 tsf @@ -1579,7 +1583,7 @@ subroutine write_gfssfc(filename,mype_sfc,dsfct) ! program history log: ! 2004-06-15 treadon - updated documentation ! 2004-07-15 todling - protex-compliant prologue; added intent/only's -! 2004-12-03 treadon - replace mpe_igatherv (IBM extension) with +! 2004-12-03 treadon - replace mpe_igatherv (ibm extension) with ! standard mpi_gatherv ! 2005-01-27 treadon - rewrite to make use of sfcio module ! 2005-02-09 kleist - clean up unit number and filename for updated surface file @@ -1682,7 +1686,7 @@ subroutine write_gfssfc(filename,mype_sfc,dsfct) sfcall,ijn,displs_g,mpi_rtype,mype_sfc,& mpi_comm_world,ierror) -! Only MPI task mype_sfc writes the surface file. +! Only mpi task mype_sfc writes the surface file. if (mype==mype_sfc) then ! Reorder updated skin temperature to output format @@ -1780,24 +1784,24 @@ subroutine write_gfs_sfc_nst(mype_so,dsfct) ! DESCRIPTION: ! 1. Background -! In the current operational GFS, although the atmospheric variables are +! In the current operational gfs, although the atmospheric variables are ! analyzed/updated 6-hourly, -! the surface variables are handled differently. The SST and sea ice are +! the surface variables are handled differently. The sst and sea ice are ! updated 24-hourly with the independent analysis. The land variables are ! not analyzed yet and the 6-hour forecast is simply used as their analysis. -! Practically, the analysis file (sfcanl) is generated by updating SST and sea +! Practically, the analysis file (sfcanl) is generated by updating sst and sea ! ice in the 6-hour forecasting file (sfcf06 or sfcges) with globale_cycle. ! -! With NSST model to provide the diurnal warming (dTw) and sub-layer cooling -! (dTc) at atmospheric model time step, and Tr analysis to provide the -! foundation temperature (Tf) analysis every 6 hour, SST = Tf + dTw - dTc -! This enable to update SST (Tr as well) 6-hourly as the atmospheric +! With nsst model to provide the diurnal warming (dtw) and sub-layer cooling +! (dtc) at atmospheric model time step, and tr analysis to provide the +! foundation temperature (tf) analysis every 6 hour, sst = tf + dtw - dtc +! This enable to update sst (tr as well) 6-hourly as the atmospheric ! variables ! the new files (nstf06, nstges and nstanl) needs to be processed ! ! 2. When nst_gsi > 0, This routine generates the sfc & nst analysis files (sfcanl and nstanl) by ! (1) reading sfcgcy (sfcf06 applied with global_cycle) and nstf06 -! (2) writing/updating the SST (tsea) and Tr (tref) respectively to get sfcanl and nstanl +! (2) writing/updating the sst (tsea) and tr (tref) respectively to get sfcanl and nstanl ! ! 3. The interpolation of global dsfct at one grids (lower resolaution, e.g.,1152 x 576) ! to another grids (higher resolution, e.g., 1760 x 880) with surface mask @@ -1815,14 +1819,14 @@ subroutine write_gfs_sfc_nst(mype_so,dsfct) ! At present, the interpolation is only performed for open water grids(0) ! ! 4. Notes -! (1) Tr (foundation temperature), instead of skin temperature, is the analysis variable. +! (1) tr (foundation temperature), instead of skin temperature, is the analysis variable. ! (2) The generation of sfanl is nst_gsi dependent. -! nst_gsi = 0 (default): No NST info at all; -! nst_gsi = 1 : Input NST info but not used in GSI -! nst_gsi = 2 : Input NST info, used in CRTM simulation but no -! Tr analysis -! nst_gsi = 3 : Input NST info, used in both CRTM simulation -! and Tr analysis +! nst_gsi = 0 (default): No nst info at all; +! nst_gsi = 1 : Input nst info but not used in gsi +! nst_gsi = 2 : Input nst info, used in crtm simulation but no +! tr analysis +! nst_gsi = 3 : Input nst info, used in both crtm simulation +! and tr analysis ! (3) The surface file (sfcgcy) read in has been updated with global_cycle ! (4) Generally, here, the interpolation of the discontinuous field is ! handled. It is required in more applications, for example, the @@ -1847,10 +1851,10 @@ subroutine write_gfs_sfc_nst(mype_so,dsfct) use guess_grids, only: isli2 use gsi_nstcouplermod, only: nst_gsi,zsea1,zsea2 use sfcio_module, only: sfcio_intkind,sfcio_head,sfcio_data,& - sfcio_srohdc,sfcio_swohdc,sfcio_axdata + sfcio_srohdc,sfcio_swohdc,sfcio_axdata use nstio_module, only: nstio_intkind,nstio_head,nstio_data,& - nstio_srohdc,nstio_swohdc,nstio_axdata + nstio_srohdc,nstio_swohdc,nstio_axdata implicit none ! @@ -1945,21 +1949,21 @@ subroutine write_gfs_sfc_nst(mype_so,dsfct) isli_all,ijn,displs_g,mpi_itype,mype_so ,& mpi_comm_world,ierror) ! -! Only MPI task mype_so, writes the surface & nst file. +! Only mpi task mype_so, writes the surface & nst file. ! if (mype==mype_so) then - write(*,'(a,5(1x,a6))') 'write_gfs_sfc_nst:',fname_sfcges,fname_nstges,fname_sfctsk,fname_sfcanl,fname_nstanl + write(*,'(a,5(1x,a6))') 'write_gfs_sfc_nst:',fname_sfcges,fname_nstges,fname_sfctsk,fname_sfcanl,fname_nstanl ! -! get Tf analysis increment and surface mask at analysis (lower resolution) -! grids +! get tf analysis increment and surface mask at analysis (lower resolution) +! grids ! - do i=1,iglobal - ilon=ltosj(i) - ilat=ltosi(i) - dsfct_glb(ilat,ilon) = dsfct_all(i) - isli_glb (ilat,ilon) = isli_all (i) - end do + do i=1,iglobal + ilon=ltosj(i) + ilat=ltosi(i) + dsfct_glb(ilat,ilon) = dsfct_all(i) + isli_glb (ilat,ilon) = isli_all (i) + end do ! ! write dsfct_anl to a data file for later use (at eupd step at present) ! @@ -2062,41 +2066,41 @@ subroutine write_gfs_sfc_nst(mype_so,dsfct) ! data_nst%slmsk = data_sfcanl%slmsk ! -! update tref (in nst file) & tsea (in the surface file) when Tr analysis is on -! reset NSSTM variables for new open water grids +! update tref (in nst file) & tsea (in the surface file) when tr analysis is on +! reset nsstm variables for new open water grids ! if ( nst_gsi > 2 ) then ! -! For the new open water (sea ice just melted) grids, (1) set dsfct_anl = zero; (2) reset the NSSTM variables +! For the new open water (sea ice just melted) grids, (1) set dsfct_anl = zero; (2) reset the nsstm variables ! ! Notes: data_sfcges%slmsk is the mask of the background ! data_sfcanl%slmsk is the mask of the analysis since global_cycle has been applied ! where ( data_sfcanl%slmsk(:,:) == zero .and. data_sfcges%slmsk(:,:) == two ) - dsfct_anl(:,:) = zero - - data_nst%xt(:,:) = zero - data_nst%xs(:,:) = zero - data_nst%xu(:,:) = zero - data_nst%xv(:,:) = zero - data_nst%xz(:,:) = z_w_max - data_nst%zm(:,:) = zero - data_nst%xtts(:,:) = zero - data_nst%xzts(:,:) = zero - data_nst%dt_cool(:,:) = zero - data_nst%z_c(:,:) = zero - data_nst%c_0(:,:) = zero - data_nst%c_d(:,:) = zero - data_nst%w_0(:,:) = zero - data_nst%w_d(:,:) = zero - data_nst%d_conv(:,:) = zero - data_nst%ifd(:,:) = zero - data_nst%tref(:,:) = tfrozen - data_nst%qrain(:,:) = zero + dsfct_anl(:,:) = zero + + data_nst%xt(:,:) = zero + data_nst%xs(:,:) = zero + data_nst%xu(:,:) = zero + data_nst%xv(:,:) = zero + data_nst%xz(:,:) = z_w_max + data_nst%zm(:,:) = zero + data_nst%xtts(:,:) = zero + data_nst%xzts(:,:) = zero + data_nst%dt_cool(:,:) = zero + data_nst%z_c(:,:) = zero + data_nst%c_0(:,:) = zero + data_nst%c_d(:,:) = zero + data_nst%w_0(:,:) = zero + data_nst%w_d(:,:) = zero + data_nst%d_conv(:,:) = zero + data_nst%ifd(:,:) = zero + data_nst%tref(:,:) = tfrozen + data_nst%qrain(:,:) = zero end where ! -! update analysis variable: Tref (foundation temperature) for nst file +! update analysis variable: tref (foundation temperature) for nst file ! where ( data_sfcanl%slmsk(:,:) == zero ) data_nst%tref(:,:) = max(data_nst%tref(:,:) + dsfct_anl(:,:),tfrozen) @@ -2104,10 +2108,10 @@ subroutine write_gfs_sfc_nst(mype_so,dsfct) data_nst%tref(:,:) = data_sfcgcy%tsea(:,:) end where ! -! update SST: tsea for sfc file +! update sst: tsea for sfc file ! - r_zsea1 = 0.001_r_single*real(zsea1) - r_zsea2 = 0.001_r_single*real(zsea2) + r_zsea1 = 0.001_r_single*real(zsea1,r_single) + r_zsea2 = 0.001_r_single*real(zsea2,r_single) call dtzm_2d(data_nst%xt,data_nst%xz,data_nst%dt_cool,data_nst%z_c, & data_sfcanl%slmsk,r_zsea1,r_zsea2,lonb,latb,dtzm) @@ -2129,7 +2133,7 @@ subroutine write_gfs_sfc_nst(mype_so,dsfct) end do end do ! -! For the new open water (sea ice just melted) grids, reset the NSSTM variables +! For the new open water (sea ice just melted) grids, reset the nsstm variables ! where ( data_sfcanl%slmsk(:,:) == zero .and. data_sfcges%slmsk(:,:) == two ) data_nst%xt(:,:) = zero @@ -2152,7 +2156,7 @@ subroutine write_gfs_sfc_nst(mype_so,dsfct) data_nst%qrain(:,:) = zero end where ! -! update tsea when NO Tf analysis +! update tsea when no tf analysis ! do j=1,latb do i=1,lonb @@ -2212,7 +2216,7 @@ end subroutine write_gfs_sfc_nst subroutine write_tf_inc_nc(mype_so,xvar2) ! -! abstract: get a global dtf and msk used in GSI by gatjering sub-domanin ones and write them in netCDF +! abstract: get a global dtf and msk used in gsi by gathering sub-domanin ones and write them in netcdf ! ! REMARKS: ! @@ -2233,7 +2237,10 @@ subroutine write_tf_inc_nc(mype_so,xvar2) ! ! USES: ! - use netcdf + use netcdf, only: nf90_clobber,nf90_64bit_offset,nf90_create,& + nf90_def_dim,nf90_def_var,nf90_real,nf90_put_att,& + nf90_double,nf90_byte,nf90_enddef,nf90_put_var,& + nf90_close use netcdf_mod, only: nc_check use kinds, only: r_kind,i_kind @@ -2277,11 +2284,11 @@ subroutine write_tf_inc_nc(mype_so,xvar2) character (len = *), parameter :: lat_name = "latitude" character (len = *), parameter :: lon_name = "longitude" integer(i_kind) :: lat_dimid, lon_dimid -! The start and count arrays will tell the netCDF library where to write our data. +! The start and count arrays will tell the netcdf library where to write our data. integer(i_kind), dimension(2) :: start,count,dimids ! These program variables hold the latitudes and longitudes. integer(i_kind) :: lon_varid, lat_varid -! We will create two netCDF variables, one each for temperature and slmsk +! We will create two netcdf variables, one each for temperature and slmsk character (len = *), parameter :: dtf_name="dtf" character (len = *), parameter :: msk_name="msk" integer(i_kind) :: dtf_varid,msk_varid @@ -2316,7 +2323,7 @@ subroutine write_tf_inc_nc(mype_so,xvar2) msk_all,ijn,displs_g,mpi_itype,mype_so ,& mpi_comm_world,ierror) ! -! Only MPI task mype_so, writes the surface & nst file. +! Only mpi task mype_so, writes the surface & nst file. ! if ( mype == mype_so ) then do i=1,iglobal @@ -2325,7 +2332,7 @@ subroutine write_tf_inc_nc(mype_so,xvar2) dtf(ilon,ilat) = dtf_all(i) msk(ilon,ilat) = msk_all(i) end do -! Create the netCDF file. +! Create the netcdf file. call nc_check( nf90_create('dtfanl', cmode=ior(nf90_clobber,nf90_64bit_offset), ncid=ncid),'create_nc','dtfanl' ) ! Define the dimensions. call nc_check( nf90_def_dim(ncid, lat_name, nlat, lat_dimid),'lat_name','dtfanl' ) @@ -2334,15 +2341,15 @@ subroutine write_tf_inc_nc(mype_so,xvar2) ! Define the coordinate variables. call nc_check( nf90_def_var(ncid, lat_name, nf90_real, lat_dimid, lat_varid),'lat_dim','dtfanl' ) call nc_check( nf90_def_var(ncid, lon_name, nf90_real, lon_dimid, lon_varid),'lon_dim','dtfanl' ) -! Assign units attributes to coordinate variables +! Assign units attributes to coordinate variables call nc_check( nf90_put_att(ncid, lat_varid, units, lat_units),'lat_unit','dtfanl' ) call nc_check( nf90_put_att(ncid, lon_varid, units, lon_units),'lon_unit','dtfanl' ) -! The dimids array is used to pass the dimids of the dimensions of the netCDF variables. +! The dimids array is used to pass the dimids of the dimensions of the netcdf variables. dimids = (/ lon_dimid, lat_dimid /) -! Define the netCDF variables for the Tf and slmsk data. +! Define the netcdf variables for the tf and slmsk data. call nc_check( nf90_def_var(ncid, dtf_name, nf90_double, dimids, dtf_varid),'dtf_type','dtfanl' ) call nc_check( nf90_def_var(ncid, msk_name, nf90_byte, dimids, msk_varid),'msk_type','dtfanl' ) -! Assign units attributes to the netCDF variables. +! Assign units attributes to the netcdf variables. call nc_check( nf90_put_att(ncid, dtf_varid, units, dtf_units),'lat_name','dtfanl' ) call nc_check( nf90_put_att(ncid, msk_varid, units, msk_units),'lat_name','dtfanl' ) ! End define mode. @@ -2381,24 +2388,24 @@ subroutine write_ens_sfc_nst(mype_so,dsfct) ! ! DESCRIPTION: ! 1. Background -! In the current operational GFS, although the atmospheric variables are +! In the current operational gfs, although the atmospheric variables are ! analyzed/updated 6-hourly, -! the surface variables are handled differently. The SST and sea ice are +! the surface variables are handled differently. The sst and sea ice are ! updated 24-hourly with the independent analysis. The land variables are ! not analyzed yet and the 6-hour forecast is simply used as their analysis. -! Practically, the analysis file is generated by updating SST and sea +! Practically, the analysis file is generated by updating sst and sea ! ice in the 6-hour forecasting surface file/files with globale_cycle evry ! 24 hours. ! -! With th the development of NSST, where the NSST model to provide the -! diurnal warming (dTw) and sub-layer cooling -! (dTc) at atmospheric model time step, and Tr analysis to provide the -! foundation temperature (Tf) analysis every 6 hour, SST = Tf + dTw - dTc -! This enable to update SST (Tr as well) 6-hourly as the atmospheric +! With the development of nsst, where the nsst model to provide the +! diurnal warming (dtw) and sub-layer cooling +! (dtc) at atmospheric model time step, and tr analysis to provide the +! foundation temperature (tf) analysis every 6 hour, sst = tf + dtw - dtc +! This enable to update sst (tr as well) 6-hourly as the atmospheric ! variables and ! the new files (nstf06, nstges and nstanl) needs to be processed ! -! With the implementation of Hybrid EnKF since May, 2012, there are two +! With the implementation of hybrid enkf since may, 2012, there are two ! types of surface files ! ! (1) Static analysis with higher resolution @@ -2406,21 +2413,21 @@ subroutine write_ens_sfc_nst(mype_so,dsfct) ! ! (2) Ensemble analysis with lower resolution (with member 001 as example: ! 001 to 080) -! sfcges_mem001 : 6-hour SFC forecast for each member (copied from +! sfcges_mem001 : 6-hour sfc forecast for each member (copied from ! bfg_yyyymmddhh_fhr06_mem001) -! sfcgcy_mem001 : from sfcges_mem001 but SST and sea ice updated with +! sfcgcy_mem001 : from sfcges_mem001 but sst and sea ice updated with ! global_cycle 24-hourly -! sfcanl_mem001 : from sfcgcy_mem001, SST is updated with NSST for open -! water grids in GSI +! sfcanl_mem001 : from sfcgcy_mem001, sst is updated with nsst for open +! water grids in gsi ! -! nstf06_mem001 : 6-hour NSST forecast for each member -! nstanl_mem001 : NSST analysis (only tref updated at present) +! nstf06_mem001 : 6-hour nsst forecast for each member +! nstanl_mem001 : nsst analysis (only tref updated at present) ! ! ! 2. This routine generates the sfc & nst analysis files for ensemble members ! (001 to 080) ! (1) reading sfcgcy_mem001 and nstf06_mem001 (1-80) -! (2) writing/updating the SST (tsea) or Tr (tref) in the above read in +! (2) writing/updating the sst (tsea) or tr (tref) in the above read in ! files to get sfcanl_mem001, nstanl_mem001, ! they will be renamed to be sfcanl_yyyymmddhh_mem001 and ! nstanl_yyyymmddhh_mm001 @@ -2428,16 +2435,16 @@ subroutine write_ens_sfc_nst(mype_so,dsfct) ! See write_gfs_sfc_nst ! ! 4. Notes -! (1) Tr (foundation temperature), instead of skin temperature, is the +! (1) tr (foundation temperature), instead of skin temperature, is the ! analysis variable. ! (2) The generation of sfcanl and sfcanl_yyyymmddhh_mm??? is nst_gsi ! dependent. -! nst_gsi = 0 (default): No NST info at all; -! nst_gsi = 1 : Input NST info but not used in GSI -! nst_gsi = 2 : Input NST info, used in CRTM simulation but no -! Tr analysis -! nst_gsi = 3 : Input NST info, used in both CRTM simulation -! and Tr analysis +! nst_gsi = 0 (default): No nst info at all; +! nst_gsi = 1 : Input nst info but not used in gsi +! nst_gsi = 2 : Input nst info, used in crtm simulation but no +! tr analysis +! nst_gsi = 3 : Input nst info, used in both crtm simulation +! and tr analysis ! (3) The mask info is regarded as available for different resolutions ! ! USES: @@ -2459,10 +2466,10 @@ subroutine write_ens_sfc_nst(mype_so,dsfct) use guess_grids, only: isli2 use gsi_nstcouplermod, only: nst_gsi use sfcio_module, only: sfcio_intkind,sfcio_head,sfcio_data,& - sfcio_srohdc,sfcio_swohdc,sfcio_axdata + sfcio_srohdc,sfcio_swohdc,sfcio_axdata use nstio_module, only: nstio_intkind,nstio_head,nstio_data,& - nstio_srohdc,nstio_swohdc,nstio_axdata + nstio_srohdc,nstio_swohdc,nstio_axdata implicit none ! @@ -2550,11 +2557,11 @@ subroutine write_ens_sfc_nst(mype_so,dsfct) isli_all,ijn,displs_g,mpi_itype,mype_so ,& mpi_comm_world,ierror) ! -! Only MPI task mype_so, processes and writes the surface & nst file. +! Only mpi task mype_so, processes and writes the surface & nst file. ! if (mype==mype_so) then ! -! get Tr analysis increment and surface mask at analysis grids +! get tr analysis increment and surface mask at analysis grids ! do i=1,iglobal ilon=ltosj(i) @@ -2640,9 +2647,9 @@ subroutine write_ens_sfc_nst(mype_so,dsfct) allocate(slatx(jmax),wlatx(jmax)) allocate(rlats_ens_sfc(nlat_ens_sfc),rlons_ens_sfc(nlon_ens_sfc)) call splat(4,jmax,slatx,wlatx) - dlon=two*pi/float(nlon_ens_sfc) + dlon=two*pi/real(nlon_ens_sfc,r_kind) do i=1,nlon_ens_sfc - rlons_ens_sfc(i)=float(i-1)*dlon + rlons_ens_sfc(i)=real(i-1,r_kind)*dlon end do do i=1,(nlat_ens_sfc-1)/2 rlats_ens_sfc(i+1)=-asin(slatx(i)) @@ -2696,11 +2703,11 @@ subroutine write_ens_sfc_nst(mype_so,dsfct) endif ! if ( k == 1 ) then ! -! update tref (in nst file) & tsea (in the surface file) when Tr analysis is on +! update tref (in nst file) & tsea (in the surface file) when tr analysis is on ! if ( nst_gsi > 2 ) then ! -! For the new open water (sea ice just melted) grids, reset the NSSTM variables +! For the new open water (sea ice just melted) grids, reset the nsstm variables ! ! set tref = tfrozen = 271.2_r_kind ! note: data_sfcges%slmsk is the mask of the guess @@ -2727,7 +2734,7 @@ subroutine write_ens_sfc_nst(mype_so,dsfct) data_nst%qrain(:,:) = zero end where ! -! update analysis variable: Tref (foundation temperature) for nst file +! update analysis variable: tref (foundation temperature) for nst file ! where ( data_sfcanl%slmsk(:,:) == zero ) data_nst%tref(:,:) = max(data_nst%tref(:,:) + dsfct_anl(:,:),tfrozen) @@ -2735,7 +2742,7 @@ subroutine write_ens_sfc_nst(mype_so,dsfct) data_nst%tref(:,:) = data_sfcanl%tsea(:,:) end where ! -! update SST: tsea for sfc file +! update sst: tsea for sfc file ! where ( data_sfcanl%slmsk(:,:) == zero ) data_sfcanl%tsea(:,:) = max(data_nst%tref(:,:) & @@ -2751,7 +2758,7 @@ subroutine write_ens_sfc_nst(mype_so,dsfct) do i=1,lonb data_nst%tref(i,j) = data_sfcanl%tsea(i,j) ! keep tref as tsea before analysis ! -! For the new open water (sea ice just melted) grids, reset the NSSTM variables +! For the new open water (sea ice just melted) grids, reset the nsstm variables ! if ( data_sfcanl%slmsk(i,j) == zero .and. data_nst%slmsk(i,j) == two ) then @@ -2842,53 +2849,53 @@ subroutine write_ens_dsfct(mype_so,dsfct) ! ! DESCRIPTION: ! 1. Background -! In the current operational GFS, although the atmospheric variables are +! In the current operational gfs, although the atmospheric variables are ! analyzed/updated 6-hourly, -! the surface variables are handled differently. The SST and sea ice are +! the surface variables are handled differently. The sst and sea ice are ! updated 24-hourly with the independent analysis. The land variables are ! not analyzed yet and the 6-hour forecast is simply used as their analysis. -! Practically, the analysis file is generated by updating SST and sea +! Practically, the analysis file is generated by updating sst and sea ! ice in the 6-hour forecasting surface file/files with globale_cycle evry ! 24 hours. ! -! With th the development of NSST, where the NSST model to provide the -! diurnal warming (dTw) and sub-layer cooling -! (dTc) at atmospheric model time step, and Tr analysis to provide the -! foundation temperature (Tf) analysis every 6 hour, SST = Tf + dTw - dTc -! This enable to update SST (Tr as well) 6-hourly as the atmospheric +! With the development of nsst, where the nsst model to provide the +! diurnal warming (dtw) and sub-layer cooling +! (dtc) at atmospheric model time step, and tr analysis to provide the +! foundation temperature (tf) analysis every 6 hour, sst = tf + dtw - dtc +! This enable to update sst (tr as well) 6-hourly as the atmospheric ! variables and ! the new files (nstf06, nstges and nstanl) needs to be processed ! -! With the implementation of Hybrid EnKF since May, 2012, there are two +! With the implementation of hybrid enkf since may, 2012, there are two ! types of surface files ! ! (1) Static analysis with higher resolution ! handled in write_gfs_sfc_nst ! ! (2) Ensemble analysis with lower resolution (with member 001 as example:001 to 080) -! sfcges_mem001 : 6-hour SFC forecast for each member (copied from +! sfcges_mem001 : 6-hour sfc forecast for each member (copied from ! bfg_yyyymmddhh_fhr06_mem001) -! sfcgcy_mem001 : from sfcges_mem001 but SST and sea ice updated with +! sfcgcy_mem001 : from sfcges_mem001 but sst and sea ice updated with ! global_cycle 24-hourly -! sfcanl_mem001 : from sfcgcy_mem001, SST is updated with NSST for open -! water grids in GSI +! sfcanl_mem001 : from sfcgcy_mem001, sst is updated with nsst for open +! water grids in gsi ! -! nstf06_mem001 : 6-hour NSST forecast for each member -! nstanl_mem001 : NSST analysis (only tref updated at present) +! nstf06_mem001 : 6-hour nsst forecast for each member +! nstanl_mem001 : nsst analysis (only tref updated at present) ! ! ! 2. This routine generates the surface temperature analysis increment for ensemble members (the same for all 80 members) -! (1) read sfcgcy_mem001 and nstf06_mem001 to get the masks (GES and -! ANL)for ensemble members +! (1) read sfcgcy_mem001 and nstf06_mem001 to get the masks (ges and +! anl)for ensemble members ! (2) get dsfct at ensemble grids (interpolation if needed) ! (3) write dsfct in a file for later nst (tref) and sfc (tsea) update at ! recenter step ! -! 3. Surface mask dependent Interpolation +! 3. Surface mask dependent interpolation ! See write_gfs_sfc_nst ! ! 4. Notes -! (1) Tr (foundation temperature), instead of skin temperature, is the +! (1) tr (foundation temperature), instead of skin temperature, is the ! analysis variable., but not analyzed yet with the current scheme ! (2) The mask info is regarded as available for different resolutions ! @@ -2909,10 +2916,10 @@ subroutine write_ens_dsfct(mype_so,dsfct) use constants, only: zero_single,zero,half,two,pi,tfrozen use guess_grids, only: isli2 use sfcio_module, only: sfcio_intkind,sfcio_head,sfcio_data,& - sfcio_srohdc,sfcio_swohdc,sfcio_axdata + sfcio_srohdc,sfcio_swohdc,sfcio_axdata use nstio_module, only: nstio_intkind,nstio_head,nstio_data,& - nstio_srohdc,nstio_swohdc,nstio_axdata + nstio_srohdc,nstio_swohdc,nstio_axdata implicit none ! @@ -2997,11 +3004,11 @@ subroutine write_ens_dsfct(mype_so,dsfct) isli_all,ijn,displs_g,mpi_itype,mype_so ,& mpi_comm_world,ierror) ! -! Only MPI task mype_so, processes and writes the surface & nst file. +! Only mpi task mype_so, processes and writes the surface & nst file. ! if (mype==mype_so) then ! -! get Tr analysis increment and surface mask at analysis grids +! get tr analysis increment and surface mask at analysis grids ! do i=1,iglobal ilon=ltosj(i) @@ -3059,7 +3066,7 @@ subroutine write_ens_dsfct(mype_so,dsfct) nlon_ens_sfc = lonb allocate(dsfct_gsi(nlat_ens_sfc,nlon_ens_sfc),work(nlat_ens_sfc,nlon_ens_sfc), & - isli_gsi(nlat_ens_sfc,nlon_ens_sfc),dsfct_anl(nlon_ens_sfc,nlat_ens_sfc-2)) + isli_gsi(nlat_ens_sfc,nlon_ens_sfc),dsfct_anl(nlon_ens_sfc,nlat_ens_sfc-2)) allocate(dsfct_tmp(nlat,nlon),isli_tmp(nlat,nlon)) @@ -3074,9 +3081,9 @@ subroutine write_ens_dsfct(mype_so,dsfct) allocate(slatx(jmax),wlatx(jmax)) allocate(rlats_ens_sfc(nlat_ens_sfc),rlons_ens_sfc(nlon_ens_sfc)) call splat(4,jmax,slatx,wlatx) - dlon=two*pi/float(nlon_ens_sfc) + dlon=two*pi/real(nlon_ens_sfc,r_kind) do i=1,nlon_ens_sfc - rlons_ens_sfc(i)=float(i-1)*dlon + rlons_ens_sfc(i)=real(i-1,r_kind)*dlon end do do i=1,(nlat_ens_sfc-1)/2 rlats_ens_sfc(i+1)=-asin(slatx(i)) @@ -3115,7 +3122,7 @@ subroutine write_ens_dsfct(mype_so,dsfct) end do end do - else ! when the GSI analysis grid is identical to ensemble one and + else ! when the gsi analysis grid is identical to ensemble one and ! no surface mask change from ges to anl ! @@ -3199,18 +3206,18 @@ subroutine sigio_cnvtdv8(im,ix,km,idvc,idvm,ntrac,iret,t,q,cpi,cnflg) real(r_kind) :: xcp(ix,km), sumq(ix,km) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - iret=0 - thermodyn_id = mod(IDVM/10,10) + thermodyn_id = mod(idvm/10,10) ! if (thermodyn_id == 3 .and. idvc == 3) then xcp(1:im,:) = zero sumq(1:im,:) = zero - do n=1,NTRAC + do n=1,ntrac if( cpi(n) /= zero) then xcp(1:im,:) = xcp(1:im,:) + q(1:im,:,n) * cpi(n) sumq(1:im,:) = sumq(1:im,:) + q(1:im,:,n) endif enddo - xcp(1:im,:) = (one-sumq(1:im,:))*cpi(0) + xcp(1:im,:) ! Mean Cp + xcp(1:im,:) = (one-sumq(1:im,:))*cpi(0) + xcp(1:im,:) ! Mean cp ! else xcp(1:im,:) = one + fv*Q(1:im,:,1) ! Virt factor @@ -3247,7 +3254,7 @@ subroutine glbave(fld,ave) enddo enddo enddo - xave=xave/(two_quad*float(nlon)) + xave=xave/(two_quad*real(nlon,r_quad)) call mpl_allreduce(size(ave,1),qpvals=xave) ave=xave deallocate(xave) diff --git a/src/gsi/ncepnems_io.f90 b/src/gsi/ncepnems_io.f90 index 0525b83bf9..28f57ba4a6 100755 --- a/src/gsi/ncepnems_io.f90 +++ b/src/gsi/ncepnems_io.f90 @@ -5,40 +5,40 @@ module ncepnems_io ! prgmmr: Huang org: np23 date: 2010-02-22 ! ! abstract: This module contains routines which handle input/output -! operations for NCEP NEMS global atmospheric and surface files. +! operations for ncep nems global atmospheric and surface files. ! ! program history log: ! 2010-02-22 Huang Initial version. Based on ncepgfs_io -! 2010-10-18 Huang Remove subroutine reorder_gfsgrib for no longer been called in GSI -! For Now, subroutine sfc_interpolate is kept in ncepgfs_io.f90. +! 2010-10-18 Huang Remove subroutine reorder_gfsgrib for no longer been called in gsi +! For now, subroutine sfc_interpolate is kept in ncepgfs_io.f90. ! When sigio and gfsio are both retired, i.e., remove ncepgfs_io.f90. ! move this routines back to this module -! 2011-03-03 Huang Changes has been made to adopt to high resolution GSI run (T382 & T574) -! both for CPU and memory issues. +! 2011-03-03 Huang Changes has been made to adopt to high resolution gsi run (t382 & t574) +! both for cpu and memory issues. ! Future development of nemsio need to consider a mapping routine be -! inserted between read-in forecast field and GSI first guess field, -! as well as GSI analysis field and write-out data field for forecast -! model. Due to computation resource, GSI may not be able to run at -! the same resolution as that of forecast model, e.g., run GSI at T382 -! w/ T574 forecast model output. +! inserted between read-in forecast field and gsi first guess field, +! as well as gsi analysis field and write-out data field for forecast +! model. Due to computation resource, gsi may not be able to run at +! the same resolution as that of forecast model, e.g., run gsi at t382 +! w/ t574 forecast model output. ! 2011-10-25 Huang (1) Add unified error message routine to make the code cleaner ! (2) To reduce the memory allocation as low as possible, remove all ! reference to sfc_head and re-used the same local arrays. ! Remove unneeded nemsio_data & gfsdata. ! (3) Add parallel IO code to read_atm_ -! 2011-11-01 Huang (1) add integer nst_gsi to control the mode of NSST +! 2011-11-01 Huang (1) add integer nst_gsi to control the mode of nsst ! (2) add read_nemsnst to read ncep nst file ! (3) add subroutine write_nemssfc_nst to save sfc and nst files ! 2016-01-01 Li (1) Move tran_gfssfc from ncepgfs_io.f90 to here ! (2) Modify write_sfc_nst_ to follows the update done in sfcio -! (3) Modify read_sfc_ to follows the update done in sfcio for more effective I/O -! 2016-04-20 Li Modify to handle the updated nemsio sig file (P, DP & DPDT removed) +! (3) Modify read_sfc_ to follows the update done in sfcio for more effective i/o +! 2016-04-20 Li Modify to handle the updated nemsio sig file (p, dp & dpdt removed) ! 2016-08-18 li - tic591: add read_sfc_anl & read_nemssfc_anl to read nemsio sfc file (isli only) with analysis resolution ! change/modify sfc_interpolate to be intrp22 to handle more general interpolation (2d to 2d) ! 2016-11-18 li - tic615: change nst mask name from slmsk to land ! 2017-08-30 li - tic659: modify read_nems_sfc_ and read_sfc_ to read sfc file in -! nemsio Gaussin grids generated by FV3 WriteComponent -! 2018-05-19 eliu - add I/O component for fv3 hydrometeors +! nemsio gaussin grids generated by fv3 writecomponent +! 2018-05-19 eliu - add i/o component for fv3 hydrometeors ! ! Subroutines Included: ! sub read_nems - driver to read ncep nems atmospheric and surface @@ -47,7 +47,7 @@ module ncepnems_io ! on grid to analysis subdomains ! sub read_nemssfc - read ncep nems surface file, scatter on grid to ! analysis subdomains -! sub read_nemssfc_anl- read ncep EnKF nems surface file, scatter on grid to +! sub read_nemssfc_anl- read ncep enkf nems surface file, scatter on grid to ! analysis subdomains ! sub write_nems - driver to write ncep nems atmospheric and surface ! analysis files @@ -55,14 +55,14 @@ module ncepnems_io ! sub write_nemssfc - gather/write on grid ncep surface analysis file ! sub read_nemsnst - read ncep nst file, scatter on grid to analysis subdomains ! sub write_nems_sfc_nst - gather/write on grid ncep surface & nst analysis file -! sub intrp22 - interpolate from one grid to another grid (2D) +! sub intrp22 - interpolate from one grid to another grid (2d) ! sub read_nems_sfcnst - read sfc hist file, including sfc and nst vars, scatter on grid to analysis subdomains ! ! Variable Definitions: -! The difference of time Info between operational GFS IO (gfshead%, sfc_head%), -! analysis time (iadate), and NEMSIO (idate=) +! The difference of time Info between operational gfs io (gfshead%, sfc_head%), +! analysis time (iadate), and nemsio (idate=) ! -! gfshead & sfc_head NEMSIO Header Analysis time (obsmod) +! gfshead & sfc_head nemsio header Analysis time (obsmod) ! =================== ============================ ========================== ! %idate(1) Hour idate(1) Year iadate(1) Year ! %idate(2) Month idate(2) Month iadate(2) Month @@ -72,23 +72,23 @@ module ncepnems_io ! idate(6) Scaled seconds ! idate(7) Seconds multiplier ! -! The difference of header forecasting hour Info bewteen operational GFS IO -! (gfshead%, sfc_head%) and NEMSIO +! The difference of header forecasting hour Info bewteen operational gfs io +! (gfshead%, sfc_head%) and nemsio ! -! gfshead & sfc_head NEMSIO Header +! gfshead & sfc_head nemsio header ! ========================== ============================ -! %fhour FCST Hour (r_kind) nfhour FCST Hour (i_kind) -! nfminute FCST Mins (i_kind) -! nfsecondn FCST Secs (i_kind) numerator -! nfsecondd FCST Secs (i_kind) denominator +! %fhour fcst hour (r_kind) nfhour fcst hour (i_kind) +! nfminute fcst mins (i_kind) +! nfsecondn fcst secs (i_kind) numerator +! nfsecondd fcst secs (i_kind) denominator ! ! %fhour = float(nfhour) + float(nfminute)/r60 + float(nfsecondn)/float(nfsecondd)/r3600 ! ! nframe - nframe is the number of grids extend outward from the ! edge of modeling domain. ! -! NEMSIO provides a more flexible read. User can get the -! size of record (1D) to be read from file header. The +! nemsio provides a more flexible read. User can get the +! size of record (1d) to be read from file header. The ! normal record size should be delx*dely, i.e., total model ! grid points. However, some regional models also ouput ! additional data of grids around the modeling domain @@ -100,21 +100,21 @@ module ncepnems_io ! To simplify the code for reading and writing global model ! files, we will not factor in the nframe for computing ! array size or array index shift (by nframe) between -! input/output array and internal GSI array. The normal -! size of I/O record remains as delx*dely. Add a checking +! input/output array and internal gsi array. The normal +! size of i/o record remains as delx*dely. Add a checking ! routine to assure nframe=zero. ! -! def imp_physics - type of microphysics used in the GFS. 99: Zhao-Carr, 11: GFDL -! def lupp - if T, UPP is used and additional variables are output +! def imp_physics - type of microphysics used in the gfs. 99: zhao-carr, 11: gfdl +! def lupp - if t, upp is used and additional variables are output ! ! attributes: ! language: f90 ! machine: ! -! NOTE: When global meteorology switched to NEMS/GFS, all routines and -! modules of old GFS (sigio) can be deactivated. To keep the code +! Note: When global meteorology switched to nems/gfs, all routines and +! modules of old gfs (sigio) can be deactivated. To keep the code ! clean, all "nems" can be replaced by "gfs" for minimal changes -! of GSI code structure. For dual purpose, two distincit routine +! of gsi code structure. For dual purpose, two distincit routine ! names are used to accomodiate old and new systems. It is now ! controled by a namelist argument "use_gfs_nemsio" ! @@ -201,14 +201,14 @@ module ncepnems_io subroutine init_ !$$$ subprogram documentation block ! . . . -! subprogram: read_nems +! subprogram: init_nems ! ! prgrmmr: Todling ! ! abstract: ! ! program history log: -! 2019-07-11 Todling - create to initialize vars that should not be in CV file +! 2019-07-11 Todling - create to initialize vars that should not be in cv file ! ! input argument list: ! @@ -234,11 +234,11 @@ subroutine read_ ! ! program history log: ! 2010-03-31 Huang - create routine based on read_gfs -! 2010-10-19 Huang - remove spectral part for gridded NEMS/GFS +! 2010-10-19 Huang - remove spectral part for gridded nems/gfs ! 2011-05-01 todling - cwmr no longer in guess-grids; use metguess bundle now ! 2013-10-19 todling - metguess now holds background ! 2016-03-30 todling - update interface to general read (pass bundle) -! 2016-06-23 Li - Add cloud partitioning, which was missed (based on GFS +! 2016-06-23 Li - Add cloud partitioning, which was missed (based on gfs ! ticket #239, comment 18) ! 2018-05-19 eliu - add components to read in hydrometeor related ! variables @@ -278,22 +278,22 @@ subroutine read_ integer(i_kind):: it, istatus, inner_vars, num_fields integer(i_kind):: i,j,k - real(r_kind),pointer,dimension(:,: ):: ges_ps_it =>NULL() - real(r_kind),pointer,dimension(:,: ):: ges_z_it =>NULL() - real(r_kind),pointer,dimension(:,:,:):: ges_u_it =>NULL() - real(r_kind),pointer,dimension(:,:,:):: ges_v_it =>NULL() - real(r_kind),pointer,dimension(:,:,:):: ges_div_it =>NULL() - real(r_kind),pointer,dimension(:,:,:):: ges_vor_it =>NULL() - real(r_kind),pointer,dimension(:,:,:):: ges_tv_it =>NULL() - real(r_kind),pointer,dimension(:,:,:):: ges_q_it =>NULL() - real(r_kind),pointer,dimension(:,:,:):: ges_oz_it =>NULL() - real(r_kind),pointer,dimension(:,:,:):: ges_cwmr_it=>NULL() - real(r_kind),pointer,dimension(:,:,:):: ges_ql_it =>NULL() - real(r_kind),pointer,dimension(:,:,:):: ges_qi_it =>NULL() - real(r_kind),pointer,dimension(:,:,:):: ges_qr_it =>NULL() - real(r_kind),pointer,dimension(:,:,:):: ges_qs_it =>NULL() - real(r_kind),pointer,dimension(:,:,:):: ges_qg_it =>NULL() - real(r_kind),pointer,dimension(:,:,:):: ges_cf_it =>NULL() + real(r_kind),pointer,dimension(:,: ):: ges_ps_it =>null() + real(r_kind),pointer,dimension(:,: ):: ges_z_it =>null() + real(r_kind),pointer,dimension(:,:,:):: ges_u_it =>null() + real(r_kind),pointer,dimension(:,:,:):: ges_v_it =>null() + real(r_kind),pointer,dimension(:,:,:):: ges_div_it =>null() + real(r_kind),pointer,dimension(:,:,:):: ges_vor_it =>null() + real(r_kind),pointer,dimension(:,:,:):: ges_tv_it =>null() + real(r_kind),pointer,dimension(:,:,:):: ges_q_it =>null() + real(r_kind),pointer,dimension(:,:,:):: ges_oz_it =>null() + real(r_kind),pointer,dimension(:,:,:):: ges_cwmr_it=>null() + real(r_kind),pointer,dimension(:,:,:):: ges_ql_it =>null() + real(r_kind),pointer,dimension(:,:,:):: ges_qi_it =>null() + real(r_kind),pointer,dimension(:,:,:):: ges_qr_it =>null() + real(r_kind),pointer,dimension(:,:,:):: ges_qs_it =>null() + real(r_kind),pointer,dimension(:,:,:):: ges_qg_it =>null() + real(r_kind),pointer,dimension(:,:,:):: ges_cf_it =>null() type(sub2grid_info) :: grd_t logical regional @@ -313,8 +313,8 @@ subroutine read_ 'qr ', 'qs ', & 'qg ', 'cf ' /) - real(r_kind),pointer,dimension(:,:):: ptr2d =>NULL() - real(r_kind),pointer,dimension(:,:,:):: ptr3d =>NULL() + real(r_kind),pointer,dimension(:,:):: ptr2d =>null() + real(r_kind),pointer,dimension(:,:,:):: ptr3d =>null() regional=.false. inner_vars=1 @@ -325,7 +325,7 @@ subroutine read_ -! Create temporary communication information fore read routines +! Create temporary communication information fore read routines call general_sub2grid_create_info(grd_t,inner_vars,grd_a%nlat,grd_a%nlon, & grd_a%nsig,num_fields,regional) @@ -333,8 +333,8 @@ subroutine read_ call gsi_gridcreate(atm_grid,lat2,lon2,nsig) call gsi_bundlecreate(atm_bundle,atm_grid,'aux-atm-read',istatus,names2d=vars2d,names3d=vars3d) if(istatus/=0) then - write(6,*) myname_,': trouble creating atm_bundle' - call stop2(999) + write(6,*) myname_,': trouble creating atm_bundle' + call stop2(999) endif @@ -355,7 +355,7 @@ subroutine read_ inithead=.false. zflag=.false. -! Set values to actual MetGuess fields +! Set values to actual metguess fields call set_guess_ if (it==ntguessig) then @@ -497,10 +497,10 @@ subroutine read_chem_ ( iyear, month,idd ) ! ! prgrmmr: todling ! -! abstract: fills chemguess_bundle with GFS chemistry. +! abstract: fills chemguess_bundle with gfs chemistry. ! ! remarks: -! 1. Right now, only CO2 is done and even this is treated +! 1. Right now, only co2 is done and even this is treated ! as constant througout the assimialation window. ! 2. iyear and month could come from obsmod, but logically ! this program should never depend on obsmod @@ -509,8 +509,8 @@ subroutine read_chem_ ( iyear, month,idd ) ! program history log: ! 2010-12-23 Huang - initial code, based on read_gfs_chem ! 2011-06-29 todling - no explict reference to internal bundle arrays -! 2019-04-19 Wei/Martin - modified to read NEMS aerosols from either -! NGAC or FV3-Chem +! 2019-04-19 Wei/Martin - modified to read nems aerosols from either +! ngac or fv3-chem ! ! input argument list: ! @@ -549,24 +549,24 @@ subroutine read_chem_ ( iyear, month,idd ) ! Declare local variables integer(i_kind) :: igfsco2, i, j, n, iret real(r_kind),dimension(lat2):: xlats - real(r_kind),pointer,dimension(:,:,:)::p_co2=>NULL() - real(r_kind),pointer,dimension(:,:,:)::ptr3d=>NULL() + real(r_kind),pointer,dimension(:,:,:)::p_co2=>null() + real(r_kind),pointer,dimension(:,:,:)::ptr3d=>null() integer(i_kind) :: i4crtm - real(r_kind),pointer,dimension(:,:,:)::ae_du001_it=>NULL() - real(r_kind),pointer,dimension(:,:,:)::ae_du002_it=>NULL() - real(r_kind),pointer,dimension(:,:,:)::ae_du003_it=>NULL() - real(r_kind),pointer,dimension(:,:,:)::ae_du004_it=>NULL() - real(r_kind),pointer,dimension(:,:,:)::ae_du005_it=>NULL() - real(r_kind),pointer,dimension(:,:,:)::ae_ss001_it=>NULL() - real(r_kind),pointer,dimension(:,:,:)::ae_ss002_it=>NULL() - real(r_kind),pointer,dimension(:,:,:)::ae_ss003_it=>NULL() - real(r_kind),pointer,dimension(:,:,:)::ae_ss004_it=>NULL() - real(r_kind),pointer,dimension(:,:,:)::ae_so4_it=>NULL() - real(r_kind),pointer,dimension(:,:,:)::ae_ocpho_it=>NULL() - real(r_kind),pointer,dimension(:,:,:)::ae_ocphi_it=>NULL() - real(r_kind),pointer,dimension(:,:,:)::ae_bcpho_it=>NULL() - real(r_kind),pointer,dimension(:,:,:)::ae_bcphi_it=>NULL() + real(r_kind),pointer,dimension(:,:,:)::ae_du001_it=>null() + real(r_kind),pointer,dimension(:,:,:)::ae_du002_it=>null() + real(r_kind),pointer,dimension(:,:,:)::ae_du003_it=>null() + real(r_kind),pointer,dimension(:,:,:)::ae_du004_it=>null() + real(r_kind),pointer,dimension(:,:,:)::ae_du005_it=>null() + real(r_kind),pointer,dimension(:,:,:)::ae_ss001_it=>null() + real(r_kind),pointer,dimension(:,:,:)::ae_ss002_it=>null() + real(r_kind),pointer,dimension(:,:,:)::ae_ss003_it=>null() + real(r_kind),pointer,dimension(:,:,:)::ae_ss004_it=>null() + real(r_kind),pointer,dimension(:,:,:)::ae_so4_it=>null() + real(r_kind),pointer,dimension(:,:,:)::ae_ocpho_it=>null() + real(r_kind),pointer,dimension(:,:,:)::ae_ocphi_it=>null() + real(r_kind),pointer,dimension(:,:,:)::ae_bcpho_it=>null() + real(r_kind),pointer,dimension(:,:,:)::ae_bcphi_it=>null() type(sub2grid_info) :: grd_ae character(24) filename,str_crtmuse @@ -587,19 +587,19 @@ subroutine read_chem_ ( iyear, month,idd ) xlats(i) = rlats(n) enddo -! Read in CO2 +! Read in co2 call gsi_chemguess_get ( 'i4crtm::co2', igfsco2, iret ) call read_gfsco2 ( iyear,month,idd,igfsco2,xlats,& lat2,lon2,nsig,mype, p_co2 ) -! Approximation: setting all times co2 values equal to the daily co2 values +! Approximation: setting all times co2 values equal to the daily co2 values do n = 2, nfldsig call gsi_bundlegetpointer(gsi_chemguess_bundle(n),'co2',ptr3d,iret) ptr3d = p_co2 enddo -! Read in Aerosol field via nemsio +! Read in aerosol field via nemsio if ( n_aerosols_fwd > 0 ) then if ( mype == 0 ) write(6,*) 'n_aerosols_fwd and aerosol_names_fwd',n_aerosols_fwd,aerosol_names_fwd call gsi_gridcreate(chem_grid,lat2,lon2,nsig) @@ -627,7 +627,7 @@ subroutine read_chem_ ( iyear, month,idd ) ier=0 call general_read_nemsaero(grd_ae,sp_a,filename,mype,chem_bundle,& - n_aerosols_fwd,aerosol_names_fwd,.true.,ier) + n_aerosols_fwd,aerosol_names_fwd,.true.,ier) do ia=1,n_aerosols_fwd @@ -714,12 +714,12 @@ subroutine read_atm_ (grd,filename,sp_a,uvflag,vordivflag,zflag, & ! program history log: ! 2010-02-22 Huang Initial version. Based on sub read_gfsatm ! 2011-02-28 Huang Re-arrange the read sequence to be same as model -! write sequence. Alsom allocate and deallocate +! write sequence. Also, allocate and deallocate ! temporary working array immediatelt before and after ! the processing and scattering first guess field to reduce ! maximum resident memory size. Page fault can happen -! when running at high resolution GSI, e.g., T574. -! 2011-09-23 Huang Add NEMS parallel IO capability +! when running at high resolution gsi, e.g., t574. +! 2011-09-23 Huang Add nems parallel io capability ! 2013-10-25 todling reposition fill_ns,filluv_ns to commvars ! ! input argument list: @@ -742,7 +742,7 @@ subroutine read_atm_ (grd,filename,sp_a,uvflag,vordivflag,zflag, & ! machine: ibm RS/6000 SP ! !$$$ - use kinds, only: r_kind,i_kind + use kinds, only: r_single,r_kind,i_kind use gridmod, only: ntracer,ncloud,reload,itotsub use general_commvars_mod, only: fill_ns,filluv_ns,fill2_ns,filluv2_ns,ltosj_s,ltosi_s use general_specmod, only: spec_vars @@ -767,7 +767,7 @@ subroutine read_atm_ (grd,filename,sp_a,uvflag,vordivflag,zflag, & type(spec_vars) ,intent(in ) :: sp_a ! Declare local variables - character(len=120) :: my_name = 'READ_NEMSATM' + character(len=120) :: my_name = 'read_nemsatm' character(len=1) :: null = ' ' integer(i_kind),dimension(7):: idate integer(i_kind),dimension(4):: odate @@ -787,7 +787,7 @@ subroutine read_atm_ (grd,filename,sp_a,uvflag,vordivflag,zflag, & real(r_kind),dimension(sp_a%nc):: spec_vor,spec_div real(r_kind),allocatable,dimension(:) :: rwork1d0, rwork1d1, rwork1d2 real(r_kind),allocatable,dimension(:) :: rlats,rlons,clons,slons - real(4),allocatable,dimension(:) :: r4lats,r4lons + real(r_single),allocatable,dimension(:) :: r4lats,r4lons real(r_kind) :: fhour type(nemsio_gfile) :: gfile logical diff_res,eqspace @@ -814,82 +814,82 @@ subroutine read_atm_ (grd,filename,sp_a,uvflag,vordivflag,zflag, & allocate( sub_div(grd%lat2*grd%lon2,max(grd%nsig,npe)),sub_vor(grd%lat2*grd%lon2,max(grd%nsig,npe)) ) if(mype < nflds)then - call nemsio_init(iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),null,'init',istop,iret) - - call nemsio_open(gfile,filename,'READ',iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),null,'open',istop+1,iret) - - call nemsio_getfilehead(gfile,iret=iret, nframe=nframe, & - nfhour=nfhour, nfminute=nfminute, nfsecondn=nfsecondn, nfsecondd=nfsecondd, & - idate=idate, dimx=lonb, dimy=latb,dimz=levs) - - if( nframe /= 0 ) then - if ( mype == 0 ) & - write(6,*)trim(my_name),': ***ERROR*** nframe /= 0 for global model read, nframe = ', nframe - call stop2(101) - end if - - fhour = float(nfhour) + float(nfminute)/r60 + float(nfsecondn)/float(nfsecondd)/r3600 - odate(1) = idate(4) !hour - odate(2) = idate(2) !month - odate(3) = idate(3) !day - odate(4) = idate(1) !year -! -! g_* array already pre-allocate as (lat2,lon2,) => 2D and <3D> array -! - diff_res=.false. - if(latb /= nlatm2) then - diff_res=.true. - if ( mype == 0 ) write(6, & - '(a,'': different spatial dimension nlatm2 = '',i4,tr1,''latb = '',i4)') & - trim(my_name),nlatm2,latb - ! call stop2(101) - end if - if(lonb /= grd%nlon) then - diff_res=.true. - if ( mype == 0 ) write(6, & - '(a,'': different spatial dimension nlon = '',i4,tr1,''lonb = '',i4)') & - trim(my_name),grd%nlon,lonb - ! call stop2(101) - end if - if(levs /= grd%nsig)then - if ( mype == 0 ) write(6, & - '(a,'': inconsistent spatial dimension nsig = '',i4,tr1,''levs = '',i4)') & - trim(my_name),grd%nsig,levs - call stop2(101) - end if -! - allocate( grid(grd%nlon,nlatm2), grid_v(grd%nlon,nlatm2) ) - if(diff_res)then - allocate( grid_b(lonb,latb),grid_c(latb+2,lonb,1),grid2(grd%nlat,grd%nlon,1)) - allocate( grid_b2(lonb,latb),grid_c2(latb+2,lonb,1)) - end if - allocate( rwork1d0(latb*lonb) ) - allocate( rlats(latb+2),rlons(lonb),clons(lonb),slons(lonb),r4lats(lonb*latb),r4lons(lonb*latb)) - allocate(rwork1d1(latb*lonb)) - call nemsio_getfilehead(gfile,lat=r4lats,iret=iret) - call nemsio_getfilehead(gfile,lon=r4lons,iret=iret) - do j=1,latb - rlats(latb+2-j)=deg2rad*r4lats(lonb/2+(j-1)*lonb) - end do - do j=1,lonb - rlons(j)=deg2rad*r4lons(j) - end do - deallocate(r4lats,r4lons) - rlats(1)=-half*pi - rlats(latb+2)=half*pi - do j=1,lonb - clons(j)=cos(rlons(j)) - slons(j)=sin(rlons(j)) - end do - - nord_int=4 - eqspace=.false. - call g_create_egrid2agrid(grd%nlat,sp_a%rlats,grd%nlon,sp_a%rlons, & - latb+2,rlats,lonb,rlons,& - nord_int,p_high,.true.,eqspace) - deallocate(rlats,rlons) + call nemsio_init(iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),null,'init',istop,iret) + + call nemsio_open(gfile,filename,'READ',iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),null,'open',istop+1,iret) + + call nemsio_getfilehead(gfile,iret=iret, nframe=nframe, & + nfhour=nfhour, nfminute=nfminute, nfsecondn=nfsecondn, nfsecondd=nfsecondd, & + idate=idate, dimx=lonb, dimy=latb,dimz=levs) + + if( nframe /= 0 ) then + if ( mype == 0 ) & + write(6,*)trim(my_name),': ***ERROR*** nframe /= 0 for global model read, nframe = ', nframe + call stop2(101) + end if + + fhour = real(nfhour,r_kind) + real(nfminute,r_kind)/r60 + real(nfsecondn,r_kind)/real(nfsecondd,r_kind)/r3600 + odate(1) = idate(4) !hour + odate(2) = idate(2) !month + odate(3) = idate(3) !day + odate(4) = idate(1) !year +! +! g_* array already pre-allocate as (lat2,lon2,) => 2d and <3d> array +! + diff_res=.false. + if(latb /= nlatm2) then + diff_res=.true. + if ( mype == 0 ) write(6, & + '(a,'': different spatial dimension nlatm2 = '',i4,tr1,''latb = '',i4)') & + trim(my_name),nlatm2,latb + ! call stop2(101) + end if + if(lonb /= grd%nlon) then + diff_res=.true. + if ( mype == 0 ) write(6, & + '(a,'': different spatial dimension nlon = '',i4,tr1,''lonb = '',i4)') & + trim(my_name),grd%nlon,lonb + ! call stop2(101) + end if + if(levs /= grd%nsig)then + if ( mype == 0 ) write(6, & + '(a,'': inconsistent spatial dimension nsig = '',i4,tr1,''levs = '',i4)') & + trim(my_name),grd%nsig,levs + call stop2(101) + end if +! + allocate( grid(grd%nlon,nlatm2), grid_v(grd%nlon,nlatm2) ) + if(diff_res)then + allocate( grid_b(lonb,latb),grid_c(latb+2,lonb,1),grid2(grd%nlat,grd%nlon,1)) + allocate( grid_b2(lonb,latb),grid_c2(latb+2,lonb,1)) + end if + allocate( rwork1d0(latb*lonb) ) + allocate( rlats(latb+2),rlons(lonb),clons(lonb),slons(lonb),r4lats(lonb*latb),r4lons(lonb*latb)) + allocate(rwork1d1(latb*lonb)) + call nemsio_getfilehead(gfile,lat=r4lats,iret=iret) + call nemsio_getfilehead(gfile,lon=r4lons,iret=iret) + do j=1,latb + rlats(latb+2-j)=deg2rad*r4lats(lonb/2+(j-1)*lonb) + end do + do j=1,lonb + rlons(j)=deg2rad*r4lons(j) + end do + deallocate(r4lats,r4lons) + rlats(1)=-half*pi + rlats(latb+2)=half*pi + do j=1,lonb + clons(j)=cos(rlons(j)) + slons(j)=sin(rlons(j)) + end do + + nord_int=4 + eqspace=.false. + call g_create_egrid2agrid(grd%nlat,sp_a%rlats,grd%nlon,sp_a%rlons, & + latb+2,rlats,lonb,rlons,& + nord_int,p_high,.true.,eqspace) + deallocate(rlats,rlons) end if ! ! Load values into rows for south and north pole before scattering @@ -906,9 +906,9 @@ subroutine read_atm_ (grd,filename,sp_a,uvflag,vordivflag,zflag, & call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) do kk=1,itotsub - i=ltosi_s(kk) - j=ltosj_s(kk) - work(kk)=grid2(i,j,1) + i=ltosi_s(kk) + j=ltosj_s(kk) + work(kk)=grid2(i,j,1) end do else grid=reshape(rwork1d0,(/size(grid,1),size(grid,2)/)) @@ -931,9 +931,9 @@ subroutine read_atm_ (grd,filename,sp_a,uvflag,vordivflag,zflag, & call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) do kk=1,itotsub - i=ltosi_s(kk) - j=ltosj_s(kk) - work(kk)=grid2(i,j,1) + i=ltosi_s(kk) + j=ltosj_s(kk) + work(kk)=grid2(i,j,1) end do else grid=reshape(rwork1d1,(/size(grid,1),size(grid,2)/)) ! convert Pa to cb @@ -966,25 +966,25 @@ subroutine read_atm_ (grd,filename,sp_a,uvflag,vordivflag,zflag, & call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons) call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) do kk=1,itotsub - i=ltosi_s(kk) - j=ltosj_s(kk) - work(kk)=grid2(i,j,1) + i=ltosi_s(kk) + j=ltosj_s(kk) + work(kk)=grid2(i,j,1) end do do j=1,grd%nlon - do i=2,grd%nlat-1 - grid(j,grd%nlat-i)=grid2(i,j,1) - end do + do i=2,grd%nlat-1 + grid(j,grd%nlat-i)=grid2(i,j,1) + end do end do call g_egrid2agrid(p_high,grid_c2,grid2,1,1,vector) do kk=1,itotsub - i=ltosi_s(kk) - j=ltosj_s(kk) - work_v(kk)=grid2(i,j,1) + i=ltosi_s(kk) + j=ltosj_s(kk) + work_v(kk)=grid2(i,j,1) end do do j=1,grd%nlon - do i=2,grd%nlat-1 - grid_v(j,grd%nlat-i)=grid2(i,j,1) - end do + do i=2,grd%nlat-1 + grid_v(j,grd%nlat-i)=grid2(i,j,1) + end do end do else grid=reshape(rwork1d0,(/size(grid,1),size(grid,2)/)) @@ -999,7 +999,7 @@ subroutine read_atm_ (grd,filename,sp_a,uvflag,vordivflag,zflag, & call general_sptez_s_b(sp_a,sp_a,spec_div,grid_div,1) call general_sptez_s_b(sp_a,sp_a,spec_vor,grid_vor,1) - ! Load values into rows for south and north pole + ! Load values into rows for south and north pole call fill_ns(grid_div,work_div) call fill_ns(grid_vor,work_vor) deallocate(grid_vor,grid_div) @@ -1052,9 +1052,9 @@ subroutine read_atm_ (grd,filename,sp_a,uvflag,vordivflag,zflag, & call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) do kk=1,itotsub - i=ltosi_s(kk) - j=ltosj_s(kk) - work(kk)=grid2(i,j,1) + i=ltosi_s(kk) + j=ltosj_s(kk) + work(kk)=grid2(i,j,1) end do else grid=reshape(rwork1d0,(/size(grid,1),size(grid,2)/)) @@ -1071,9 +1071,9 @@ subroutine read_atm_ (grd,filename,sp_a,uvflag,vordivflag,zflag, & call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) do kk=1,itotsub - i=ltosi_s(kk) - j=ltosj_s(kk) - work_v(kk)=grid2(i,j,1) + i=ltosi_s(kk) + j=ltosj_s(kk) + work_v(kk)=grid2(i,j,1) end do else grid_v=reshape(rwork1d2,(/size(grid_v,1),size(grid_v,2)/)) @@ -1111,9 +1111,9 @@ subroutine read_atm_ (grd,filename,sp_a,uvflag,vordivflag,zflag, & call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) do kk=1,itotsub - i=ltosi_s(kk) - j=ltosj_s(kk) - work(kk)=grid2(i,j,1) + i=ltosi_s(kk) + j=ltosj_s(kk) + work(kk)=grid2(i,j,1) end do else grid=reshape(rwork1d0,(/size(grid,1),size(grid,2)/)) @@ -1154,9 +1154,9 @@ subroutine read_atm_ (grd,filename,sp_a,uvflag,vordivflag,zflag, & call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) do kk=1,itotsub - i=ltosi_s(kk) - j=ltosj_s(kk) - work(kk)=grid2(i,j,1) + i=ltosi_s(kk) + j=ltosj_s(kk) + work(kk)=grid2(i,j,1) end do else grid=reshape(rwork1d0,(/size(grid,1),size(grid,2)/)) @@ -1226,10 +1226,10 @@ subroutine read_sfc_(sfct,soil_moi,sno,soil_temp,veg_frac,fact10,sfc_rough, & ! z_c - optional, depth of sub-layer cooling layer ! dt_warm - optional, diurnal warming amount at sea surface ! z_w - optional, depth of diurnal warming layer -! c_0 - optional, coefficient to calculate d(Tz)/d(tr) in dimensionless -! c_d - optional, coefficient to calculate d(Tz)/d(tr) in m^-1 -! w_0 - optional, coefficient to calculate d(Tz)/d(tr) in dimensionless -! w_d - optional, coefficient to calculate d(Tz)/d(tr) in m^-1 +! c_0 - optional, coefficient to calculate d(tz)/d(tr) in dimensionless +! c_d - optional, coefficient to calculate d(tz)/d(tr) in m^-1 +! w_0 - optional, coefficient to calculate d(tz)/d(tr) in dimensionless +! w_d - optional, coefficient to calculate d(tz)/d(tr) in m^-1 ! ! attributes: @@ -1260,7 +1260,7 @@ subroutine read_sfc_(sfct,soil_moi,sno,soil_temp,veg_frac,fact10,sfc_rough, & ! Declare local variables real(r_single), dimension(nlat_sfc,nlon_sfc,nfldsfc) :: xt character(len=24) :: filename - character(len=120) :: my_name = 'READ_SFCNST' + character(len=120) :: my_name = 'read_sfcnst' character(len=1) :: null = ' ' integer(i_kind) :: i,j,it,n,nsfc integer(i_kind) :: iret, nframe, lonb, latb @@ -1291,11 +1291,11 @@ subroutine read_sfc_(sfct,soil_moi,sno,soil_temp,veg_frac,fact10,sfc_rough, & if( nframe /= 0 ) then if ( mype == 0 ) & - write(6,*)trim(my_name),': ***ERROR*** nframe /= 0 for global sfc hist read, nframe = ', nframe + write(6,*)trim(my_name),': ***ERROR*** nframe /= 0 for global sfc hist read, nframe = ', nframe call stop2(102) end if - fhour = float(nfhour) + float(nfminute)/r60 + float(nfsecondn)/float(nfsecondd)/r3600 + fhour = real(nfhour,r_single) + real(nfminute,r_single)/r60 + real(nfsecondn,r_single)/real(nfsecondd,r_single)/r3600 odate(1) = idate(4) !hour odate(2) = idate(2) !month odate(3) = idate(3) !day @@ -1308,7 +1308,7 @@ subroutine read_sfc_(sfct,soil_moi,sno,soil_temp,veg_frac,fact10,sfc_rough, & call stop2(102) endif ! -! Read the surface records (lonb, latb) and convert to GSI array pattern (nlat_sfc,nlon_sfc) +! Read the surface records (lonb, latb) and convert to gsi array pattern (nlat_sfc,nlon_sfc) ! Follow the read order sfcio in ncepgfs_io ! allocate(work(lonb,latb)) @@ -1317,16 +1317,16 @@ subroutine read_sfc_(sfct,soil_moi,sno,soil_temp,veg_frac,fact10,sfc_rough, & rwork2d = zero if(it == 1)then - nsfc=nsfc_all + nsfc=nsfc_all else - nsfc=nsfc_all-4 + nsfc=nsfc_all-4 end if do n = 1, nsfc if (n == 1) then ! skin temperature -! Tsea +! tsea call nemsio_readrecv(gfile, 'tmp', 'sfc', 1, rwork2d, iret=iret) if (iret /= 0) call error_msg(trim(my_name),trim(filename),'tmp','read',istop,iret) work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) @@ -1336,12 +1336,12 @@ subroutine read_sfc_(sfct,soil_moi,sno,soil_temp,veg_frac,fact10,sfc_rough, & ! smc/soilw call nemsio_readrecv(gfile, 'smc', 'soil layer', 1, rwork2d, iret=iret) - ! FV3 nemsio files use 'soilw 0-10cm down' insted of 'smc soil layer 1' + ! fv3 nemsio files use 'soilw 0-10cm down' insted of 'smc soil layer 1' if (iret /= 0) then - if ( mype == 0 ) print *,'could not read smc, try to read soilw 0-10 cm down instead...' - call nemsio_readrecv(gfile,'soilw','0-10 cm down',1,rwork2d,iret=iret) - if (iret /= 0) & - call error_msg(trim(my_name),trim(filename),'smc/soilw','read',istop,iret) + if ( mype == 0 ) print *,'could not read smc, try to read soilw 0-10 cm down instead...' + call nemsio_readrecv(gfile,'soilw','0-10 cm down',1,rwork2d,iret=iret) + if (iret /= 0) & + call error_msg(trim(my_name),trim(filename),'smc/soilw','read',istop,iret) endif work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) call tran_gfssfc(work,soil_moi(1,1,it),lonb,latb) @@ -1359,11 +1359,11 @@ subroutine read_sfc_(sfct,soil_moi,sno,soil_temp,veg_frac,fact10,sfc_rough, & ! stc/tmp call nemsio_readrecv(gfile, 'stc', 'soil layer', 1, rwork2d, iret=iret) if (iret /= 0) then - ! FV3 nemsio files use 'tmp 0-10cm down' insted of 'stc soil layer 1' - if ( mype == 0 ) print *,'could not read stc, try to read tmp 0-10 cm down instead...' - call nemsio_readrecv(gfile,'tmp','0-10 cm down',1,rwork2d,iret=iret) - if (iret /= 0) & - call error_msg(trim(my_name),trim(filename),'stc/tmp','read',istop,iret) + ! fv3 nemsio files use 'tmp 0-10cm down' insted of 'stc soil layer 1' + if ( mype == 0 ) print *,'could not read stc, try to read tmp 0-10 cm down instead...' + call nemsio_readrecv(gfile,'tmp','0-10 cm down',1,rwork2d,iret=iret) + if (iret /= 0) & + call error_msg(trim(my_name),trim(filename),'stc/tmp','read',istop,iret) endif work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) call tran_gfssfc(work,soil_temp(1,1,it),lonb,latb) @@ -1541,10 +1541,10 @@ subroutine read_nemssfc_(iope,sfct,soil_moi,sno,soil_temp,veg_frac,fact10,sfc_ro ! z_c - optional, depth of sub-layer cooling layer ! dt_warm - optional, diurnal warming amount at sea surface ! z_w - optional, depth of diurnal warming layer -! c_0 - optional, coefficient to calculate d(Tz)/d(tf) -! c_d - optional, coefficient to calculate d(Tz)/d(tf) -! w_0 - optional, coefficient to calculate d(Tz)/d(tf) -! w_d - optional, coefficient to calculate d(Tz)/d(tf) +! c_0 - optional, coefficient to calculate d(tz)/d(tf) +! c_d - optional, coefficient to calculate d(tz)/d(tf) +! w_0 - optional, coefficient to calculate d(tz)/d(tf) +! w_d - optional, coefficient to calculate d(tz)/d(tf) ! ! attributes: ! language: f90 @@ -1659,7 +1659,7 @@ subroutine read_sfc_anl_(isli_anl) ! Declare local variables character(len=24) :: filename - character(len=120) :: my_name = 'READ_NEMSSFC_ANL' + character(len=120) :: my_name = 'read_sfc_anl' character(len=1) :: null = ' ' integer(i_kind) :: i,j integer(i_kind) :: iret, nframe, lonb, latb @@ -1694,7 +1694,7 @@ subroutine read_sfc_anl_(isli_anl) call stop2(102) end if - fhour = float(nfhour) + float(nfminute)/r60 + float(nfsecondn)/float(nfsecondd)/r3600 + fhour = real(nfhour,r_single) + real(nfminute,r_single)/r60 + real(nfsecondn,r_single)/real(nfsecondd,r_single)/r3600 odate(1) = idate(4) !hour odate(2) = idate(2) !month odate(3) = idate(3) !day @@ -1707,7 +1707,7 @@ subroutine read_sfc_anl_(isli_anl) call stop2(102) endif ! -! Read the surface records (lonb, latb) and convert to GSI array pattern (nlat,nlon) +! Read the surface records (lonb, latb) and convert to gsi array pattern (nlat,nlon) ! Follow the read order sfcio in ncepgfs_io ! allocate(work(lonb,latb)) @@ -1793,14 +1793,14 @@ subroutine read_nst_ (tref,dt_cool,z_c,dt_warm,z_w,c_0,c_d,w_0,w_d) !$$$ subprogram documentation block ! . . . . ! subprogram: read_nst_ read nems nst surface guess file (quadratic -! Gaussin grids) without scattering to tasks +! gaussian grids) without scattering to tasks ! prgmmr: Huang org: np23 date: 2011-11-01 ! -! abstract: read nems surface NST file +! abstract: read nems surface nst file ! ! program history log: ! 2011-11-01 Huang Initial version based on sub read_gfsnst -! 2016-03-13 Li Modify for more effective I/O +! 2016-03-13 Li Modify for more effective i/o ! ! input argument list: ! @@ -1810,10 +1810,10 @@ subroutine read_nst_ (tref,dt_cool,z_c,dt_warm,z_w,c_0,c_d,w_0,w_d) ! z_c (:,:) ! depth of sub-layer cooling layer ! dt_warm (:,:) ! diurnal warming amount at sea surface (skin layer) ! z_w (:,:) ! depth of diurnal warming layer -! c_0 (:,:) ! coefficient to calculate d(Tz)/d(tr) -! c_d (:,:) ! coefficient to calculate d(Tz)/d(tr) -! w_0 (:,:) ! coefficient to calculate d(Tz)/d(tr) -! w_d (:,:) ! coefficient to calculate d(Tz)/d(tr) +! c_0 (:,:) ! coefficient to calculate d(tz)/d(tr) +! c_d (:,:) ! coefficient to calculate d(tz)/d(tr) +! w_0 (:,:) ! coefficient to calculate d(tz)/d(tr) +! w_d (:,:) ! coefficient to calculate d(tz)/d(tr) ! ! attributes: ! language: f90 @@ -1839,7 +1839,7 @@ subroutine read_nst_ (tref,dt_cool,z_c,dt_warm,z_w,c_0,c_d,w_0,w_d) ! Declare local variables character(len=6) :: filename - character(len=120) :: my_name = 'READ_NEMSNST' + character(len=120) :: my_name = 'read_nst' character(len=1) :: null = ' ' integer(i_kind) :: i,j,it,latb,lonb integer(i_kind) :: iret, nframe @@ -1874,11 +1874,11 @@ subroutine read_nst_ (tref,dt_cool,z_c,dt_warm,z_w,c_0,c_d,w_0,w_d) if( nframe /= 0 ) then if ( mype == 0 ) & - write(6,*)trim(my_name),': ***ERROR*** nframe /= 0 for global model read, nframe = ', nframe + write(6,*)trim(my_name),': ***ERROR*** nframe /= 0 for global model read, nframe = ', nframe call stop2(istop) end if - fhour = float(nfhour) + float(nfminute)/r60 + float(nfsecondn)/float(nfsecondd)/r3600 + fhour = real(nfhour,r_single) + real(nfminute,r_single)/r60 + real(nfsecondn,r_single)/real(nfsecondd,r_single)/r3600 odate(1) = idate(4) !hour odate(2) = idate(2) !month odate(3) = idate(3) !day @@ -1892,14 +1892,14 @@ subroutine read_nst_ (tref,dt_cool,z_c,dt_warm,z_w,c_0,c_d,w_0,w_d) endif ! ! Load surface fields into local work array -! Follow NEMS/GFS sfcf read order +! Follow nems/gfs sfcf read order ! allocate(work(lonb,latb)) allocate(rwork2d(size(work,1)*size(work,2))) work = zero rwork2d = zero -! Tref +! tref call nemsio_readrecv(gfile, 'tref', 'sfc', 1, rwork2d, iret=iret) if (iret /= 0) call error_msg(trim(my_name),trim(filename),'tref','read',istop,iret) work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) @@ -1954,7 +1954,7 @@ subroutine read_nst_ (tref,dt_cool,z_c,dt_warm,z_w,c_0,c_d,w_0,w_d) call tran_gfssfc(work,w_d(1,1,it),lonb,latb) ! -! Get diurnal warming amout at z=0 +! Get diurnal warming amount at z=0 ! do j = 1,nlon_sfc do i = 1,nlat_sfc @@ -1992,10 +1992,10 @@ subroutine read_nemsnst_ (iope,tref,dt_cool,z_c,dt_warm,z_w,c_0,c_d,w_0,w_d) ! z_c (:,:) ! depth of sub-layer cooling layer ! dt_warm (:,:) ! diurnal warming amount at sea surface ! z_w (:,:) ! depth of diurnal warming layer -! c_0 (:,:) ! coefficient to calculate d(Tz)/d(tr) in dimensionless -! c_d (:,:) ! coefficient to calculate d(Tz)/d(tr) in m^-1 -! w_0 (:,:) ! coefficient to calculate d(Tz)/d(tr) in dimensionless -! w_d (:,:) ! coefficient to calculate d(Tz)/d(tr) in m^-1 +! c_0 (:,:) ! coefficient to calculate d(tz)/d(tr) in dimensionless +! c_d (:,:) ! coefficient to calculate d(tz)/d(tr) in m^-1 +! w_0 (:,:) ! coefficient to calculate d(tz)/d(tr) in dimensionless +! w_d (:,:) ! coefficient to calculate d(tz)/d(tr) in m^-1 ! ! attributes: ! language: f90 @@ -2050,20 +2050,20 @@ subroutine write_fv3atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin) ! ! prgmmr: eliu org: np23 date: 2018-05-15 ! -! abstract: This routine gathers fields needed for the GSI analysis +! abstract: This routine gathers fields needed for the gsi analysis ! file from subdomains and then transforms the fields from ! analysis grid to model guess grid, then written to an ! atmospheric analysis file. ! ! program history log: -! 2018-05-19 eliu Initial version. Based on write_nemsatm (Huang) +! 2018-05-19 eliu Initial version. Based on write_nemsatm (huang) ! ! input argument list: -! filename - file to open and write to -! mype_out - mpi task to write output file -! gfs_bundle - bundle containing fields on subdomains -! ibin - time bin -! gfschem_bundle - (optional) bundle containing chemistry fields +! filename - file to open and write to +! mype_out - mpi task to write output file +! gfs_bundle - bundle containing fields on subdomains +! ibin - time bin +! gfschem_bundle - (optional) bundle containing chemistry fields ! ! output argument list: ! @@ -2074,7 +2074,7 @@ subroutine write_fv3atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin) !$$$ end documentation block ! !USES: - use kinds, only: r_kind,i_kind + use kinds, only: r_single,r_kind,i_kind use constants, only: r1000,fv,one,zero,qcmin,r0_05,t0c @@ -2095,7 +2095,7 @@ subroutine write_fv3atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin) use obsmod, only: iadate use nemsio_module, only: nemsio_gfile,nemsio_open,nemsio_init,& - nemsio_getfilehead,nemsio_close,nemsio_writerecv,nemsio_readrecv + nemsio_getfilehead,nemsio_close,nemsio_writerecv,nemsio_readrecv use gsi_4dvar, only: ibdate,nhr_obsbin,lwrite4danl use general_sub2grid_mod, only: sub2grid_info use egrid2agrid_mod,only: g_egrid2agrid,g_create_egrid2agrid,egrid2agrid_parm,destroy_egrid2agrid @@ -2121,7 +2121,7 @@ subroutine write_fv3atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin) real(r_kind),parameter:: r0_001 = 0.001_r_kind character(6):: fname_ges - character(len=120) :: my_name = 'WRITE_FV3ATM_NEMS' + character(len=120) :: my_name = 'write_fv3atm_nems' character(len=1) :: null = ' ' integer(i_kind),dimension(7):: idate, jdate integer(i_kind),dimension(4):: odate @@ -2150,7 +2150,7 @@ subroutine write_fv3atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin) real(r_kind),dimension(max(grd%iglobal,grd%itotsub)) :: work1,work2 real(r_kind),dimension(grd%nlon,grd%nlat-2):: grid real(r_kind),allocatable,dimension(:) :: rwork1d,rwork1d1,rlats,rlons,clons,slons - real(4),allocatable,dimension(:) :: r4lats,r4lons + real(r_single),allocatable,dimension(:) :: r4lats,r4lons real(r_kind),allocatable,dimension(:,:) :: grid_b,grid_b2 real(r_kind),allocatable,dimension(:,:,:) :: grid_c, grid3, grid_c2 type(nemsio_gfile) :: gfile,gfileo @@ -2185,18 +2185,18 @@ subroutine write_fv3atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin) call gsi_bundlegetpointer(gfs_bundle,'qg', sub_qg,iret); istatus=istatus+iret if ( istatus /= 0 ) then if ( mype == 0 ) then - write(6,*) 'write_fv3atm_: ERROR' - write(6,*) 'Missing some of the required fields' - write(6,*) 'Aborting ... ' - endif - call stop2(999) + write(6,*) 'write_fv3atm_: ERROR' + write(6,*) 'Missing some of the required fields' + write(6,*) 'Aborting ... ' + endif + call stop2(999) endif if ( sp_a%jcap /= jcap_b ) then - if ( mype == 0 ) write(6, & - '('' dual resolution for nems sp_a%jcap,jcap_b = '',2i6)') & - sp_a%jcap,jcap_b - diff_res = .true. + if ( mype == 0 ) write(6, & + '('' dual resolution for nems sp_a%jcap,jcap_b = '',2i6)') & + sp_a%jcap,jcap_b + diff_res = .true. endif @@ -2275,7 +2275,7 @@ subroutine write_fv3atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin) call nemsio_getfilehead(gfile,lat=r4lats,iret=iret) call nemsio_getfilehead(gfile,lon=r4lons,iret=iret) do j=1,latb - rlats(latb+2-j)=deg2rad*r4lats(lonb/2+(j-1)*lonb) + rlats(latb+2-j)=deg2rad*r4lats(lonb/2+(j-1)*lonb) enddo rlats(1)=-half*pi rlats(latb+2)=half*pi @@ -2307,7 +2307,7 @@ subroutine write_fv3atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin) if (iret /= 0) call error_msg(trim(my_name),trim(filename),'hgt','write',istop,iret) endif ! if ( mype == mype_out ) - ! Calculate delz increment for UPP + ! Calculate delz increment for upp if (lupp) then do k=1,grd%nsig sub_dzb(:,:,k) = ges_geopi(:,:,k+1,ibin) - ges_geopi(:,:,k,ibin) @@ -2337,10 +2337,10 @@ subroutine write_fv3atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin) if (lupp) call strip(sub_dza ,dzsm ,grd%nsig) ! Thermodynamic variable - ! The GSI analysis variable is virtual temperature (Tv). For NEMSIO + ! The gsi analysis variable is virtual temperature (tv). For nemsio ! output we need the sensible temperature. - ! Convert Tv to T + ! Convert tv to t tvsm = tvsm/(one+fv*qsm) ! Generate and write analysis fields @@ -2658,7 +2658,7 @@ subroutine write_fv3atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin) if(diff_res)then call nemsio_readrecv(gfile,'rwmr','mid layer',k,rwork1d,iret=iret) if (iret /= 0) call error_msg(trim(my_name),trim(filename),'rwmr','read',istop,iret) - grid_b=reshape(rwork1d,(/size(grid_b,1),size(grid_b,2)/)) + grid_b=reshape(rwork1d,(/size(grid_b,1),size(grid_b,2)/)) vector(1)=.false. call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) call g_egrid2agrid(p_low,grid_c,grid3,1,1,vector) @@ -2725,10 +2725,10 @@ subroutine write_fv3atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin) endif else if (mype == mype_out) then - call nemsio_readrecv(gfile,'snmr','mid layer',k,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'snmr','read',istop,iret) - call nemsio_writerecv(gfileo,'snmr','mid layer',k,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'snmr','write',istop,iret) + call nemsio_readrecv(gfile,'snmr','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'snmr','read',istop,iret) + call nemsio_writerecv(gfileo,'snmr','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'snmr','write',istop,iret) endif endif end do @@ -2774,7 +2774,7 @@ subroutine write_fv3atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin) endif endif end do -! Cloud Amount (cloud fraction) - should be the same as the input guess values +! Cloud amount (cloud fraction) - should be the same as the input guess values do k=1,grd%nsig if (mype==mype_out) then call nemsio_readrecv(gfile,'cld_amt','mid layer',k,rwork1d,iret=iret) @@ -2785,7 +2785,7 @@ subroutine write_fv3atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin) endif enddo endif !ntracer -! Variables needed by the Unified Post Processor (dzdt, delz, delp) +! Variables needed by the unified post processor (dzdt, delz, delp) if (lupp) then if (mype == mype_out) then do k=1,grd%nsig @@ -2800,10 +2800,10 @@ subroutine write_fv3atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin) work1,grd%ijn,grd%displs_g,mpi_rtype,& mype_out,mpi_comm_world,ierror) if (mype == mype_out) then - work1 = -one * work1 ! Flip sign, FV3 is top to bottom + work1 = -one * work1 ! Flip sign, fv3 is top to bottom call nemsio_readrecv(gfile,'delz','mid layer',k,rwork1d,iret=iret) if (iret /= 0) call error_msg(trim(my_name),trim(filename),'delz','read',istop,iret) - if (sum(rwork1d) < zero) work1 = -one * work1 !Flip sign, FV3 is top to bottom + if (sum(rwork1d) < zero) work1 = -one * work1 !Flip sign, fv3 is top to bottom if(diff_res)then grid_b=reshape(rwork1d,(/size(grid_b,1),size(grid_b,2)/)) do kk=1,grd%iglobal @@ -2828,7 +2828,7 @@ subroutine write_fv3atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin) end do endif ! -! Deallocate local array +! Deallocate local array ! if (mype==mype_out) then if (diff_res .or. lupp) deallocate(grid_b,grid_b2,grid_c,grid_c2,grid3,clons,slons) @@ -2857,7 +2857,7 @@ subroutine write_atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin,gfschem_bundle ! ! prgmmr: Huang org: np23 date: 2010-02-22 ! -! abstract: This routine gathers fields needed for the GSI analysis +! abstract: This routine gathers fields needed for the gsi analysis ! file from subdomains and then transforms the fields from ! analysis grid to model guess grid, then written to an ! atmospheric analysis file. @@ -2869,13 +2869,13 @@ subroutine write_atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin,gfschem_bundle ! 2013-10-25 todling reposition load_grid to commvars ! 2016-07-28 mahajan update with bundling ability ! 2019-04-19 Wei/Martin - added gfschem_bundle to write optional aerosols -! for both FV3-Chem and NGAC +! for both fv3-chem and ngac ! ! input argument list: -! filename - file to open and write to -! mype_out - mpi task to write output file -! gfs_bundle - bundle containing fields on subdomains -! ibin - time bin +! filename - file to open and write to +! mype_out - mpi task to write output file +! gfs_bundle - bundle containing fields on subdomains +! ibin - time bin ! ! output argument list: ! @@ -2886,7 +2886,7 @@ subroutine write_atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin,gfschem_bundle !$$$ end documentation block ! !USES: - use kinds, only: r_kind,i_kind + use kinds, only: r_single,r_kind,i_kind use constants, only: r1000,fv,one,zero,qcmin,r0_05,t0c @@ -2910,7 +2910,7 @@ subroutine write_atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin,gfschem_bundle use obsmod, only: iadate use nemsio_module, only: nemsio_gfile,nemsio_open,nemsio_init,& - nemsio_getfilehead,nemsio_close,nemsio_writerecv,nemsio_readrecv + nemsio_getfilehead,nemsio_close,nemsio_writerecv,nemsio_readrecv use gsi_4dvar, only: ibdate,nhr_obsbin,lwrite4danl use general_sub2grid_mod, only: sub2grid_info use egrid2agrid_mod,only: g_egrid2agrid,g_create_egrid2agrid,egrid2agrid_parm,destroy_egrid2agrid @@ -2936,7 +2936,7 @@ subroutine write_atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin,gfschem_bundle real(r_kind),parameter:: r0_001 = 0.001_r_kind character(6):: fname_ges - character(len=120) :: my_name = 'WRITE_NEMSATM' + character(len=120) :: my_name = 'write_nemsatm' character(len=1) :: null = ' ' integer(i_kind),dimension(7):: idate, jdate integer(i_kind),dimension(4):: odate @@ -2974,7 +2974,7 @@ subroutine write_atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin,gfschem_bundle real(r_kind),dimension(max(grd%iglobal,grd%itotsub)) :: work1,work2 real(r_kind),dimension(grd%nlon,grd%nlat-2):: grid real(r_kind),allocatable,dimension(:) :: rwork1d,rwork1d1,rlats,rlons,clons,slons - real(4),allocatable,dimension(:) :: r4lats,r4lons + real(r_single),allocatable,dimension(:) :: r4lats,r4lons real(r_kind),allocatable,dimension(:,:) :: grid_b,grid_b2 real(r_kind),allocatable,dimension(:,:,:) :: grid_c, grid3, grid_c2, grid3b @@ -2999,11 +2999,11 @@ subroutine write_atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin,gfschem_bundle call gsi_bundlegetpointer(gfs_bundle,'cw', sub_cwmr,iret); istatus=istatus+iret if ( istatus /= 0 ) then if ( mype == 0 ) then - write(6,*) 'write_atm_: ERROR' - write(6,*) 'Missing some of the required fields' - write(6,*) 'Aborting ... ' - endif - call stop2(999) + write(6,*) 'write_atm_: ERROR' + write(6,*) 'Missing some of the required fields' + write(6,*) 'Aborting ... ' + endif + call stop2(999) endif if (present(gfschem_bundle) .and. laeroana_gocart) then @@ -3107,12 +3107,12 @@ subroutine write_atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin,gfschem_bundle call nemsio_getfilehead(gfile,lat=r4lats,iret=iret) call nemsio_getfilehead(gfile,lon=r4lons,iret=iret) do j=1,latb - rlats(latb+2-j)=deg2rad*r4lats(lonb/2+(j-1)*lonb) + rlats(latb+2-j)=deg2rad*r4lats(lonb/2+(j-1)*lonb) enddo rlats(1)=-half*pi rlats(latb+2)=half*pi do j=1,lonb - rlons(j)=deg2rad*r4lons(j) + rlons(j)=deg2rad*r4lons(j) enddo do j=1,lonb clons(j)=cos(rlons(j)) @@ -3146,7 +3146,7 @@ subroutine write_atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin,gfschem_bundle sub_dp(:,:,k) = sub_prsi(:,:,k) - sub_prsi(:,:,k+1) end do - ! Calculate delz increment for UPP + ! Calculate delz increment for upp if (lupp) then do k=1,grd%nsig sub_dzb(:,:,k) = ges_geopi(:,:,k+1,ibin) - ges_geopi(:,:,k,ibin) @@ -3188,10 +3188,10 @@ subroutine write_atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin,gfschem_bundle end if ! Thermodynamic variable - ! The GSI analysis variable is virtual temperature (Tv). For NEMSIO + ! The gsi analysis variable is virtual temperature (tv). For nemsio ! output we need the sensible temperature. - ! Convert Tv to T + ! Convert tv to t tvsm = tvsm/(one+fv*qsm) ! Generate and write analysis fields @@ -3516,7 +3516,7 @@ subroutine write_atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin,gfschem_bundle end do endif !ntracer -! Variables needed by the Unified Post Processor (dzdt, delz, delp) +! Variables needed by the unified post processor (dzdt, delz, delp) if (lupp) then if (mype == mype_out) then do k=1,grd%nsig @@ -3559,8 +3559,8 @@ subroutine write_atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin,gfschem_bundle end do endif -! aerosol output if laeroana_gocart is T -! du001 +! aerosol output if laeroana_gocart is t +! du001 if (laeroana_gocart) then do k=1,grd%nsig call mpi_gatherv(du001sm(1,k),grd%ijn(mm1),mpi_rtype,& @@ -3603,7 +3603,7 @@ subroutine write_atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin,gfschem_bundle if (iret /= 0) call error_msg(trim(my_name),trim(filename),'du001','write',istop,iret) endif end do -! du002 +! du002 do k=1,grd%nsig call mpi_gatherv(du002sm(1,k),grd%ijn(mm1),mpi_rtype,& work1,grd%ijn,grd%displs_g,mpi_rtype,& @@ -3645,7 +3645,7 @@ subroutine write_atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin,gfschem_bundle if (iret /= 0) call error_msg(trim(my_name),trim(filename),'du002','write',istop,iret) endif end do -! du003 +! du003 do k=1,grd%nsig call mpi_gatherv(du003sm(1,k),grd%ijn(mm1),mpi_rtype,& work1,grd%ijn,grd%displs_g,mpi_rtype,& @@ -3687,7 +3687,7 @@ subroutine write_atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin,gfschem_bundle if (iret /= 0) call error_msg(trim(my_name),trim(filename),'du003','write',istop,iret) endif end do -! du004 +! du004 do k=1,grd%nsig call mpi_gatherv(du004sm(1,k),grd%ijn(mm1),mpi_rtype,& work1,grd%ijn,grd%displs_g,mpi_rtype,& @@ -3729,7 +3729,7 @@ subroutine write_atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin,gfschem_bundle if (iret /= 0) call error_msg(trim(my_name),trim(filename),'du004','write',istop,iret) endif end do -! du005 +! du005 do k=1,grd%nsig call mpi_gatherv(du005sm(1,k),grd%ijn(mm1),mpi_rtype,& work1,grd%ijn,grd%displs_g,mpi_rtype,& @@ -3771,8 +3771,8 @@ subroutine write_atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin,gfschem_bundle if (iret /= 0) call error_msg(trim(my_name),trim(filename),'du005','write',istop,iret) endif end do -! ss001 and ss002 NOTE: It depends the ratio of ss1 and ss2 in guess to -! distribute the analysis mixing ratio +! ss001 and ss002 Note: It depends the ratio of ss1 and ss2 in guess to +! distribute the analysis mixing ratio do k=1,grd%nsig call mpi_gatherv(ss001sm(1,k),grd%ijn(mm1),mpi_rtype,& work1,grd%ijn,grd%displs_g,mpi_rtype,& @@ -3820,8 +3820,8 @@ subroutine write_atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin,gfschem_bundle call load_grid(work1,grid) rwork1d = reshape(grid,(/size(rwork1d)/)) ! analysis total mixing ratio end if - ! if there is increment in analysis but nothing originally, half-half to - ! analysis sea salt 1 and 2 respectively. + ! if there is increment in analysis but nothing originally, half-half to + ! analysis sea salt 1 and 2 respectively. ! do m=1,size(rwork1d) if (rwork1d(m) /= zero .and. rwork1d1(m) == zero ) then ! if ana!=0, ratio=0. Then ss1=ss2=half total mixing ratio @@ -3849,7 +3849,7 @@ subroutine write_atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin,gfschem_bundle end if endif end do -! ss003 +! ss003 do k=1,grd%nsig call mpi_gatherv(ss002sm(1,k),grd%ijn(mm1),mpi_rtype,& work1,grd%ijn,grd%displs_g,mpi_rtype,& @@ -3891,7 +3891,7 @@ subroutine write_atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin,gfschem_bundle if (iret /= 0) call error_msg(trim(my_name),trim(filename),'ss003','write',istop,iret) endif end do -! ss004 +! ss004 do k=1,grd%nsig call mpi_gatherv(ss003sm(1,k),grd%ijn(mm1),mpi_rtype,& work1,grd%ijn,grd%displs_g,mpi_rtype,& @@ -3933,7 +3933,7 @@ subroutine write_atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin,gfschem_bundle if (iret /= 0) call error_msg(trim(my_name),trim(filename),'ss004','write',istop,iret) endif end do -! ss005 +! ss005 do k=1,grd%nsig call mpi_gatherv(ss004sm(1,k),grd%ijn(mm1),mpi_rtype,& work1,grd%ijn,grd%displs_g,mpi_rtype,& @@ -3975,8 +3975,8 @@ subroutine write_atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin,gfschem_bundle if (iret /= 0) call error_msg(trim(my_name),trim(filename),'ss005','write',istop,iret) endif end do -! dms, msa, so2 - do k=1,grd%nsig +! dms, msa, so2 + do k=1,grd%nsig if (mype == mype_out) then if (use_fv3_aero) then call nemsio_readrecv(gfile,'DMS','mid layer',k,rwork1d,iret=iret) @@ -3991,24 +3991,24 @@ subroutine write_atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin,gfschem_bundle end if if (iret /= 0) call error_msg(trim(my_name),trim(filename),'dms','write',istop,iret) endif - end do + end do - do k=1,grd%nsig + do k=1,grd%nsig if (mype == mype_out) then call nemsio_readrecv(gfile,'msa','mid layer',k,rwork1d,iret=iret) call nemsio_writerecv(gfileo,'msa','mid layer',k,rwork1d,iret=iret) if (iret /= 0) call error_msg(trim(my_name),trim(filename),'msa','write',istop,iret) endif - end do + end do - do k=1,grd%nsig + do k=1,grd%nsig if (mype == mype_out) then call nemsio_readrecv(gfile,'so2','mid layer',k,rwork1d,iret=iret) call nemsio_writerecv(gfileo,'so2','mid layer',k,rwork1d,iret=iret) if (iret /= 0) call error_msg(trim(my_name),trim(filename),'so2','write',istop,iret) endif - end do -! so4 + end do +! so4 do k=1,grd%nsig call mpi_gatherv(so4sm(1,k),grd%ijn(mm1),mpi_rtype,& work1,grd%ijn,grd%displs_g,mpi_rtype,& @@ -4050,7 +4050,7 @@ subroutine write_atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin,gfschem_bundle if (iret /= 0) call error_msg(trim(my_name),trim(filename),'so4','write',istop,iret) endif end do -! oc1 +! oc1 do k=1,grd%nsig call mpi_gatherv(ocphosm(1,k),grd%ijn(mm1),mpi_rtype,& work1,grd%ijn,grd%displs_g,mpi_rtype,& @@ -4092,7 +4092,7 @@ subroutine write_atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin,gfschem_bundle if (iret /= 0) call error_msg(trim(my_name),trim(filename),'ocphobic','write',istop,iret) endif end do -! oc2 +! oc2 do k=1,grd%nsig call mpi_gatherv(ocphism(1,k),grd%ijn(mm1),mpi_rtype,& work1,grd%ijn,grd%displs_g,mpi_rtype,& @@ -4134,7 +4134,7 @@ subroutine write_atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin,gfschem_bundle if (iret /= 0) call error_msg(trim(my_name),trim(filename),'ocphilic','write',istop,iret) endif end do -! bc1 +! bc1 do k=1,grd%nsig call mpi_gatherv(bcphosm(1,k),grd%ijn(mm1),mpi_rtype,& work1,grd%ijn,grd%displs_g,mpi_rtype,& @@ -4176,7 +4176,7 @@ subroutine write_atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin,gfschem_bundle if (iret /= 0) call error_msg(trim(my_name),trim(filename),'bcphobic','write',istop,iret) endif end do -! bc2 +! bc2 do k=1,grd%nsig call mpi_gatherv(bcphism(1,k),grd%ijn(mm1),mpi_rtype,& work1,grd%ijn,grd%displs_g,mpi_rtype,& @@ -4219,7 +4219,7 @@ subroutine write_atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin,gfschem_bundle endif end do -! output extra variables if FV3-Chem +! output extra variables if fv3-chem if (use_fv3_aero) then do k=1,grd%nsig if (mype == mype_out) then @@ -4238,7 +4238,7 @@ subroutine write_atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin,gfschem_bundle end if end if ! end if laeroana_gocart ! -! Deallocate local array +! Deallocate local array ! if (mype==mype_out) then if (diff_res .or. lupp .or. imp_physics == 11) deallocate(grid_b,grid_b2,grid_c,grid_c2,grid3,clons,slons) @@ -4250,7 +4250,7 @@ subroutine write_atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin,gfschem_bundle call nemsio_close(gfileo,iret) if (iret /= 0) call error_msg(trim(my_name),trim(filename),null,'close',istop,iret) ! -! Deallocate local array +! Deallocate local array ! deallocate(rwork1d,rwork1d1) ! @@ -4270,9 +4270,9 @@ subroutine write_sfc_ (filename,mype_sfc,dsfct) ! abstract: This routine writes the updated surface analysis. At ! this point (20101020) the only surface field update by ! the gsi is the skin temperature. The current (20101020) -! GDAS setup does use the updated surface file. Rather, +! gdas setup does use the updated surface file. Rather, ! the output from surface cycle is used as the surface -! analysis for subsequent NEMS/GFS runs. +! analysis for subsequent nems/gfs runs. ! ! The routine gathers surface fields from subdomains, ! reformats the data records, and then writes each record @@ -4343,7 +4343,7 @@ subroutine write_sfc_ (filename,mype_sfc,dsfct) ! Declare local parameters character( 6),parameter:: fname_ges='sfcf06' ! Declare local variables - character(len=120) :: my_name = 'WRITE_NEMSSFC' + character(len=120) :: my_name = 'write_nemssfc' character(len=1) :: null = ' ' integer(i_kind),dimension(7):: idate, jdate integer(i_kind),dimension(4):: odate @@ -4380,7 +4380,7 @@ subroutine write_sfc_ (filename,mype_sfc,dsfct) sfcall,ijn,displs_g,mpi_rtype,mype_sfc,& mpi_comm_world,ierror) -! Only MPI task mype_sfc writes the surface file. +! Only mpi task mype_sfc writes the surface file. if (mype==mype_sfc) then ! Reorder updated skin temperature to output format @@ -4429,7 +4429,7 @@ subroutine write_sfc_ (filename,mype_sfc,dsfct) odate(3) = jdate(3) !day odate(4) = jdate(1) !year ! -! Start to write output sfc file : filename +! Start to write output sfc file : filename ! open new output file with new header gfileo with "write" access. ! Use this call to update header as well ! @@ -4448,13 +4448,13 @@ subroutine write_sfc_ (filename,mype_sfc,dsfct) allocate(tsea(lonb,latb)) do n = 1, nrec - call nemsio_readrec (gfile, n,rwork1d,iret=iret) - if ( iret /= 0 ) write(6,*) 'readrec nrec = ', n, ' Status = ', iret - call nemsio_writerec(gfileo,n,rwork1d,iret=iret) - if ( iret /= 0 ) write(6,*) 'writerec nrec = ', n, ' Status = ', iret + call nemsio_readrec (gfile, n,rwork1d,iret=iret) + if ( iret /= 0 ) write(6,*) 'readrec nrec = ', n, ' Status = ', iret + call nemsio_writerec(gfileo,n,rwork1d,iret=iret) + if ( iret /= 0 ) write(6,*) 'writerec nrec = ', n, ' Status = ', iret end do ! -! Only sea surface temperature will be updated in the SFC files +! Only sea surface temperature will be updated in the SFC files ! call nemsio_readrecv(gfile,'tmp','sfc',1,rwork1d,iret=iret) @@ -4505,15 +4505,15 @@ subroutine write_sfc_nst_ (mype_so,dsfct) ! prgmmr: Huang org: np23 date: 2011-11-01 ! ! abstract: This routine writes the sfc & nst analysis files and is nst_gsi dependent. -! Tr (foundation temperature), instead of skin temperature, is the analysis variable. -! nst_gsi > 2: Tr analysis is on -! nst_gsi <= 2: Tr analysis is off +! tr (foundation temperature), instead of skin temperature, is the analysis variable. +! nst_gsi > 2: tr analysis is on +! nst_gsi <= 2: tr analysis is off ! -! The routine gathers Tr field from subdomains, +! The routine gathers tr field from subdomains, ! reformats the data records, and then writes each record ! to the output files. ! -! Since the gsi only update the Tr temperature, all +! Since the gsi only update the tr temperature, all ! other fields in surface are simply read from the guess ! files and written to the analysis file. ! @@ -4590,7 +4590,7 @@ subroutine write_sfc_nst_ (mype_so,dsfct) integer(i_kind), parameter:: io_dtfanl = 54 integer(i_kind), parameter:: nprep=15 real(r_kind),parameter :: houra = zero_single - character(len=120) :: my_name = 'WRITE_SFC_NST' + character(len=120) :: my_name = 'write_sfc_nst' character(len=1) :: null = ' ' integer(i_kind),dimension(7):: idate, jdate integer(i_kind),dimension(4):: odate @@ -4652,19 +4652,19 @@ subroutine write_sfc_nst_ (mype_so,dsfct) isli_all,ijn,displs_g,mpi_itype,mype_so ,& mpi_comm_world,ierror) -! Only MPI task mype_so writes the surface file. +! Only mpi task mype_so writes the surface file. if (mype==mype_so ) then - write(*,'(a,5(1x,a6))') 'write_nems_sfc_nst:',fname_sfcges,fname_nstges,fname_sfctsk,fname_sfcanl,fname_nstanl + write(*,'(a,5(1x,a6))') 'write_nems_sfc_nst:',fname_sfcges,fname_nstges,fname_sfctsk,fname_sfcanl,fname_nstanl ! -! get Tf analysis increment and surface mask at analysis (lower resolution) grids +! get tf analysis increment and surface mask at analysis (lower resolution) grids ! - do i=1,iglobal - ilon=ltosj(i) - ilat=ltosi(i) - dsfct_glb(ilat,ilon) = dsfct_all(i) - isli_glb (ilat,ilon) = isli_all (i) - end do + do i=1,iglobal + ilon=ltosj(i) + ilat=ltosi(i) + dsfct_glb(ilat,ilon) = dsfct_all(i) + isli_glb (ilat,ilon) = isli_all (i) + end do ! ! write dsfct_anl to a data file for later use (at eupd step at present) ! @@ -4789,7 +4789,7 @@ subroutine write_sfc_nst_ (mype_so,dsfct) endif ! if ( (latb /= nlatm2) .or. (lonb /= nlon) ) then ! -! Start to write output sfc file : fname_sfcanl & fname_nstanl +! Start to write output sfc file : fname_sfcanl & fname_nstanl ! open new output file with new header gfile_sfcanl and gfile_nstanl with "write" access. ! Use this call to update header as well ! @@ -4814,10 +4814,10 @@ subroutine write_sfc_nst_ (mype_so,dsfct) call nemsio_open(gfile_nstanl,trim(fname_nstanl),'write',iret=iret, idate=jdate, nfhour=nfhour,& nfminute=nfminute, nfsecondn=nfsecondn, nfsecondd=nfsecondd ) if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),null,'open',istop,iret) -! Allocate work array (rwork1d) and tsea in sfc file +! Allocate work array (rwork1d) and tsea in sfc file allocate(tsea(lonb,latb)) -! Allocate nsst variables +! Allocate nsst variables allocate(xt(lonb,latb)) allocate(xs(lonb,latb)) allocate(xu(lonb,latb)) @@ -4852,124 +4852,124 @@ subroutine write_sfc_nst_ (mype_so,dsfct) write(*,*) 'read gfile_sfcgcy, and the write to gfile_sfcanl, gfile_sfctsk' ! -! For sfcanl, Only tsea (sea surface temperature) will be updated in the SFC +! For sfcanl, only tsea (sea surface temperature) will be updated in the sfc ! Need values from nstges for tref update ! read tsea from sfcges call nemsio_readrecv(gfile_sfcges,'tmp','sfc',1,rwork1d,iret=iret) if (iret /= 0) call error_msg(trim(my_name),trim(fname_sfcges),'tmp','read',istop,iret) tsea=reshape(rwork1d,(/size(tsea,1),size(tsea,2)/)) -! For nstanl, Only tref (foundation temperature) is updated by analysis +! For nstanl, only tref (foundation temperature) is updated by analysis ! others are updated for snow melting case ! read 18 nsst variables from nstges -! xt +! xt call nemsio_readrecv(gfile_nstges, 'xt', 'sfc', 1, rwork1d, iret=iret) if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'xt','read',istop,iret) xt=reshape(rwork1d,(/size(xt,1),size(xt,2)/)) -! xs +! xs call nemsio_readrecv(gfile_nstges, 'xs', 'sfc', 1, rwork1d, iret=iret) if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'xs','read',istop,iret) xs=reshape(rwork1d,(/size(xs,1),size(xs,2)/)) -! xu +! xu call nemsio_readrecv(gfile_nstges, 'xu', 'sfc', 1, rwork1d, iret=iret) if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'xu','read',istop,iret) xu=reshape(rwork1d,(/size(xu,1),size(xu,2)/)) -! xv +! xv call nemsio_readrecv(gfile_nstges, 'xv', 'sfc', 1, rwork1d, iret=iret) if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'xv','read',istop,iret) xv=reshape(rwork1d,(/size(xv,1),size(xv,2)/)) -! xz +! xz call nemsio_readrecv(gfile_nstges, 'xz', 'sfc', 1, rwork1d, iret=iret) if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'xz','read',istop,iret) xz=reshape(rwork1d,(/size(xz,1),size(xz,2)/)) -! zm +! zm call nemsio_readrecv(gfile_nstges, 'zm', 'sfc', 1, rwork1d, iret=iret) if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'zm','read',istop,iret) zm=reshape(rwork1d,(/size(zm,1),size(zm,2)/)) -! xtts +! xtts call nemsio_readrecv(gfile_nstges, 'xtts', 'sfc', 1, rwork1d, iret=iret) if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'xtts','read',istop,iret) xtts=reshape(rwork1d,(/size(xtts,1),size(xtts,2)/)) -! xzts +! xzts call nemsio_readrecv(gfile_nstges, 'xzts', 'sfc', 1, rwork1d, iret=iret) if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'xzts','read',istop,iret) xzts=reshape(rwork1d,(/size(xzts,1),size(xzts,2)/)) -! dt_cool +! dt_cool call nemsio_readrecv(gfile_nstges, 'dtcool','sfc', 1, rwork1d, iret=iret) if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'dt_cool','read',istop,iret) dt_cool=reshape(rwork1d,(/size(dt_cool,1),size(dt_cool,2)/)) -! z_c +! z_c call nemsio_readrecv(gfile_nstges, 'zc','sfc', 1, rwork1d, iret=iret) if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'zc','read',istop,iret) z_c=reshape(rwork1d,(/size(z_c,1),size(z_c,2)/)) -! c_0 +! c_0 call nemsio_readrecv(gfile_nstges, 'c0','sfc', 1, rwork1d, iret=iret) if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'c0','read',istop,iret) c_0=reshape(rwork1d,(/size(c_0,1),size(c_0,2)/)) -! c_d +! c_d call nemsio_readrecv(gfile_nstges, 'cd','sfc', 1, rwork1d, iret=iret) if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'cd','read',istop,iret) c_d=reshape(rwork1d,(/size(c_d,1),size(c_d,2)/)) -! w_0 +! w_0 call nemsio_readrecv(gfile_nstges, 'w0','sfc', 1, rwork1d, iret=iret) if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'w0','read',istop,iret) w_0=reshape(rwork1d,(/size(w_0,1),size(w_0,2)/)) -! w_d +! w_d call nemsio_readrecv(gfile_nstges, 'wd','sfc', 1, rwork1d, iret=iret) if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'wd','read',istop,iret) w_d=reshape(rwork1d,(/size(w_d,1),size(w_d,2)/)) -! tref +! tref call nemsio_readrecv(gfile_nstges, 'tref', 'sfc', 1, rwork1d, iret=iret) if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'tref','read',istop,iret) tref=reshape(rwork1d,(/size(tref,1),size(tref,2)/)) -! d_conv +! d_conv call nemsio_readrecv(gfile_nstges, 'dconv', 'sfc', 1, rwork1d, iret=iret) if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'dconv','read',istop,iret) d_conv=reshape(rwork1d,(/size(d_conv,1),size(d_conv,2)/)) -! ifd +! ifd call nemsio_readrecv(gfile_nstges, 'ifd', 'sfc', 1, rwork1d, iret=iret) if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'ifd','read',istop,iret) ifd=reshape(rwork1d,(/size(ifd,1),size(ifd,2)/)) -! qrain +! qrain call nemsio_readrecv(gfile_nstges, 'qrain', 'sfc', 1, rwork1d, iret=iret) if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'qrain','read',istop,iret) qrain=reshape(rwork1d,(/size(qrain,1),size(qrain,2)/)) ! -! update tref (in nst file) & tsea (in the surface file) when Tr analysis is on -! reset NSSTM variables for new open water grids +! update tref (in nst file) & tsea (in the surface file) when tr analysis is on +! reset nsstm variables for new open water grids ! if ( nst_gsi > 2 ) then ! -! For the new open water (sea ice just melted) grids, (1) set dsfct_anl = zero; (2) reset the NSSTM variables +! For the new open water (sea ice just melted) grids, (1) set dsfct_anl = zero; (2) reset the nsstm variables ! ! Notes: slmsk_ges is the mask of the background ! slmsk_anl is the mask of the analysis ! where ( slmsk_anl(:,:) == zero .and. slmsk_ges(:,:) == two ) - dsfct_anl(:,:) = zero - - xt(:,:) = zero - xs(:,:) = zero - xu(:,:) = zero - xv(:,:) = zero - xz(:,:) = z_w_max - zm(:,:) = zero - xtts(:,:) = zero - xzts(:,:) = zero - dt_cool(:,:) = zero - z_c(:,:) = zero - c_0(:,:) = zero - c_d(:,:) = zero - w_0(:,:) = zero - w_d(:,:) = zero - d_conv(:,:) = zero - ifd(:,:) = zero - tref(:,:) = tfrozen - qrain(:,:) = zero + dsfct_anl(:,:) = zero + + xt(:,:) = zero + xs(:,:) = zero + xu(:,:) = zero + xv(:,:) = zero + xz(:,:) = z_w_max + zm(:,:) = zero + xtts(:,:) = zero + xzts(:,:) = zero + dt_cool(:,:) = zero + z_c(:,:) = zero + c_0(:,:) = zero + c_d(:,:) = zero + w_0(:,:) = zero + w_d(:,:) = zero + d_conv(:,:) = zero + ifd(:,:) = zero + tref(:,:) = tfrozen + qrain(:,:) = zero end where ! -! update analysis variable: Tref (foundation temperature) for nst file +! update analysis variable: tref (foundation temperature) for nst file ! where ( slmsk_anl(:,:) == zero ) tref(:,:) = max(tref(:,:) + dsfct_anl(:,:),tfrozen) @@ -4977,10 +4977,10 @@ subroutine write_sfc_nst_ (mype_so,dsfct) tref(:,:) = tsea(:,:) end where ! -! update SST: tsea for sfc file with NSST profile +! update sst: tsea for sfc file with nsst profile ! - r_zsea1 = 0.001_r_single*real(zsea1) - r_zsea2 = 0.001_r_single*real(zsea2) + r_zsea1 = 0.001_r_single*real(zsea1,r_single) + r_zsea2 = 0.001_r_single*real(zsea2,r_single) call dtzm_2d(xt,xz,dt_cool,z_c,slmsk_anl,r_zsea1,r_zsea2,lonb,latb,dtzm) where ( slmsk_anl(:,:) == zero ) @@ -4995,31 +4995,31 @@ subroutine write_sfc_nst_ (mype_so,dsfct) end do end do ! -! For the new open water (sea ice just melted) grids, reset the NSSTM variables +! For the new open water (sea ice just melted) grids, reset the nsstm variables ! where ( slmsk_anl(:,:) == zero .and. slmsk_ges(:,:) == two ) - xt(:,:) = zero - xs(:,:) = zero - xu(:,:) = zero - xv(:,:) = zero - xz(:,:) = z_w_max - zm(:,:) = zero - xtts(:,:) = zero - xzts(:,:) = zero - dt_cool(:,:) = zero - z_c(:,:) = zero - c_0(:,:) = zero - c_d(:,:) = zero - w_0(:,:) = zero - w_d(:,:) = zero - d_conv(:,:) = zero - ifd(:,:) = zero - tref(:,:) = tfrozen - qrain(:,:) = zero + xt(:,:) = zero + xs(:,:) = zero + xu(:,:) = zero + xv(:,:) = zero + xz(:,:) = z_w_max + zm(:,:) = zero + xtts(:,:) = zero + xzts(:,:) = zero + dt_cool(:,:) = zero + z_c(:,:) = zero + c_0(:,:) = zero + c_d(:,:) = zero + w_0(:,:) = zero + w_d(:,:) = zero + d_conv(:,:) = zero + ifd(:,:) = zero + tref(:,:) = tfrozen + qrain(:,:) = zero end where ! -! update tsea when NO Tf analysis +! update tsea when no tf analysis ! do j=1,latb do i=1,lonb @@ -5047,79 +5047,79 @@ subroutine write_sfc_nst_ (mype_so,dsfct) ! ! update nsst records in nstanl ! -! slmsk +! slmsk rwork1d = reshape( slmsk_anl,(/size(rwork1d)/) ) call nemsio_writerecv(gfile_nstanl,'land','sfc',1,rwork1d,iret=iret) if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'land','write',istop,iret) -! xt +! xt rwork1d = reshape( xt,(/size(rwork1d)/) ) call nemsio_writerecv(gfile_nstanl,'xt','sfc',1,rwork1d,iret=iret) if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'xt','write',istop,iret) -! xs +! xs rwork1d = reshape( xs,(/size(rwork1d)/) ) call nemsio_writerecv(gfile_nstanl,'xs','sfc',1,rwork1d,iret=iret) if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'xs','write',istop,iret) -! xu +! xu rwork1d = reshape( xu,(/size(rwork1d)/) ) call nemsio_writerecv(gfile_nstanl,'xu','sfc',1,rwork1d,iret=iret) if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'xu','write',istop,iret) -! xv +! xv rwork1d = reshape( xv,(/size(rwork1d)/) ) call nemsio_writerecv(gfile_nstanl,'xv','sfc',1,rwork1d,iret=iret) if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'xv','write',istop,iret) -! xz +! xz rwork1d = reshape( xz,(/size(rwork1d)/) ) call nemsio_writerecv(gfile_nstanl,'xz','sfc',1,rwork1d,iret=iret) if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'xz','write',istop,iret) -! zm +! zm rwork1d = reshape( zm,(/size(rwork1d)/) ) call nemsio_writerecv(gfile_nstanl,'zm','sfc',1,rwork1d,iret=iret) if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'zm','write',istop,iret) -! xtts +! xtts rwork1d = reshape( xtts,(/size(rwork1d)/) ) call nemsio_writerecv(gfile_nstanl,'xtts','sfc',1,rwork1d,iret=iret) if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'xtts','write',istop,iret) -! xzts +! xzts rwork1d = reshape( xzts,(/size(rwork1d)/) ) call nemsio_writerecv(gfile_nstanl,'xzts','sfc',1,rwork1d,iret=iret) if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'xzts','write',istop,iret) -! z_0 +! z_0 rwork1d = reshape( dt_cool,(/size(rwork1d)/) ) call nemsio_writerecv(gfile_nstanl,'dtcool','sfc',1,rwork1d,iret=iret) if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'dtcool','write',istop,iret) -! z_c +! z_c rwork1d = reshape( z_c,(/size(rwork1d)/) ) call nemsio_writerecv(gfile_nstanl,'zc','sfc',1,rwork1d,iret=iret) if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'zc','write',istop,iret) -! c_0 +! c_0 rwork1d = reshape( c_0,(/size(rwork1d)/) ) call nemsio_writerecv(gfile_nstanl,'c0','sfc',1,rwork1d,iret=iret) if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'c0','write',istop,iret) -! c_d +! c_d rwork1d = reshape( c_d,(/size(rwork1d)/) ) call nemsio_writerecv(gfile_nstanl,'cd','sfc',1,rwork1d,iret=iret) if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'cd','write',istop,iret) -! w_0 +! w_0 rwork1d = reshape( w_0,(/size(rwork1d)/) ) call nemsio_writerecv(gfile_nstanl,'w0','sfc',1,rwork1d,iret=iret) if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'w0','write',istop,iret) -! w_d +! w_d rwork1d = reshape( w_d,(/size(rwork1d)/) ) call nemsio_writerecv(gfile_nstanl,'wd','sfc',1,rwork1d,iret=iret) if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'wd','write',istop,iret) -! d_conv +! d_conv rwork1d = reshape( d_conv,(/size(rwork1d)/) ) call nemsio_writerecv(gfile_nstanl,'dconv','sfc',1,rwork1d,iret=iret) if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'dconv','write',istop,iret) -! ifd +! ifd rwork1d = reshape( ifd,(/size(rwork1d)/) ) call nemsio_writerecv(gfile_nstanl,'ifd','sfc',1,rwork1d,iret=iret) if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'ifd','write',istop,iret) -! tref +! tref rwork1d = reshape( tref,(/size(rwork1d)/) ) call nemsio_writerecv(gfile_nstanl,'tref','sfc',1,rwork1d,iret=iret) if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'tref','write',istop,iret) -! qrain +! qrain rwork1d = reshape( qrain,(/size(rwork1d)/) ) call nemsio_writerecv(gfile_nstanl,'qrain','sfc',1,rwork1d,iret=iret) if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'qrain','write',istop,iret) @@ -5164,18 +5164,18 @@ subroutine error_msg_(sub_name,file_name,var_name,action,stop_code,error_code,lp if ( mype == 0 .or. present(lprint) ) then select case (trim(action)) - case('init') - write(6,'(a,'': PROBLEM with nemsio_init, Status = '', i3)') & - trim(sub_name), error_code - case('open') - write(6,'(a,'': ***ERROR*** problem opening file '',a,'', Status = '', i3)') & - trim(sub_name), trim(file_name), error_code - case('close') - write(6,'(a,'': ***ERROR*** problem closing file '',a,'', Status = '', i3)') & - trim(sub_name), trim(file_name), error_code - case default - write(6,'(a,'': ***ERROR*** '',a,tr1,a,'',variable = '',a,'',Status = '',i3)') & - trim(sub_name),trim(action),trim(file_name),trim(var_name),error_code + case('init') + write(6,'(a,'': PROBLEM with nemsio_init, Status = '', i3)') & + trim(sub_name), error_code + case('open') + write(6,'(a,'': ***ERROR*** problem opening file '',a,'', Status = '', i3)') & + trim(sub_name), trim(file_name), error_code + case('close') + write(6,'(a,'': ***ERROR*** problem closing file '',a,'', Status = '', i3)') & + trim(sub_name), trim(file_name), error_code + case default + write(6,'(a,'': ***ERROR*** '',a,tr1,a,'',variable = '',a,'',Status = '',i3)') & + trim(sub_name),trim(action),trim(file_name),trim(var_name),error_code end select end if if ( stop_code /= 0 ) call stop2(stop_code) @@ -5316,9 +5316,9 @@ subroutine tran_gfssfc(ain,aout,lonb,latb) sumn = ain(i,1) + sumn sums = ain(i,latb) + sums end do - sumn = sumn/float(lonb) - sums = sums/float(lonb) -! Transfer from local work array to surface guess array + sumn = sumn/real(lonb,r_kind) + sums = sums/real(lonb,r_kind) +! Transfer from local work array to surface guess array do j = 1,lonb aout(1,j)=sums do i=2,latb+1