diff --git a/src/gsi/Nst_Var_ESMFMod.f90 b/src/gsi/nst_var_esmfmod.f90 similarity index 50% rename from src/gsi/Nst_Var_ESMFMod.f90 rename to src/gsi/nst_var_esmfmod.f90 index 2344334d77..1ce5ad7055 100644 --- a/src/gsi/Nst_Var_ESMFMod.f90 +++ b/src/gsi/nst_var_esmfmod.f90 @@ -1,26 +1,26 @@ ! -! !MODULE: Nst_Var_ESMFMod --- Definition of the Nst_Var model -! fields in the ESMF internal state. +! !MODULE: nst_var_esmfmod --- Definition of the nst_var model +! fields in the esmf internal state. ! -! !DESCRIPTION: Nst_Var_ESMFMod --- Define the Nst_Var model variables -! in the ESMF internal state. +! !DESCRIPTION: nst_var_esmfmod --- Define the nst_var model variables +! in the esmf internal state. !--------------------------------------------------------------------------- ! !REVISION HISTORY: ! ! May 2008 Shrinivas Moorthi Initial code. -! Aug 2009 Xu Li for DTM-1p +! Aug 2009 Xu Li for dtm-1p ! Mar 2014 Fanglin Yang removed pointers for fixing digital filter -! Apr 2014 Xu Li introduce to and modified for GSI (from GSM) +! Apr 2014 Xu Li introduce to and modified for gsi (from gsm) ! ! !INTERFACE: ! - MODULE Nst_Var_ESMFMod + module nst_var_esmfmod use kinds, only: i_kind,r_kind - IMPLICIT none + implicit none - TYPE Nst_Var_Data + type nst_var_data real(r_kind),allocatable:: slmsk (:,:) real(r_kind),allocatable:: xt (:,:) real(r_kind),allocatable:: xs (:,:) @@ -39,8 +39,8 @@ MODULE Nst_Var_ESMFMod real(r_kind),allocatable:: d_conv (:,:) real(r_kind),allocatable:: ifd (:,:) real(r_kind),allocatable:: tref (:,:) - real(r_kind),allocatable:: Qrain (:,:) - end type Nst_Var_Data + real(r_kind),allocatable:: qrain (:,:) + end type nst_var_data !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! contains subroutine nstvar_aldata(dim1,dim2,data,iret) @@ -49,29 +49,29 @@ subroutine nstvar_aldata(dim1,dim2,data,iret) type(nst_var_data),intent(inout) :: data integer(i_kind), intent(out) :: iret ! -allocate( & - data%slmsk (dim1,dim2), & - data%xt (dim1,dim2), & - data%xs (dim1,dim2), & - data%xu (dim1,dim2), & - data%xv (dim1,dim2), & - data%xz (dim1,dim2), & - data%zm (dim1,dim2), & - data%xtts (dim1,dim2), & - data%xzts (dim1,dim2), & - data%dt_cool (dim1,dim2), & - data%z_c (dim1,dim2), & - data%c_0 (dim1,dim2), & - data%c_d (dim1,dim2), & - data%w_0 (dim1,dim2), & - data%w_d (dim1,dim2), & - data%d_conv (dim1,dim2), & - data%ifd (dim1,dim2), & - data%tref (dim1,dim2), & - data%Qrain (dim1,dim2), & - stat=iret) - if(iret.ne.0) iret=-3 - return - end subroutine nstvar_aldata + allocate( & + data%slmsk (dim1,dim2), & + data%xt (dim1,dim2), & + data%xs (dim1,dim2), & + data%xu (dim1,dim2), & + data%xv (dim1,dim2), & + data%xz (dim1,dim2), & + data%zm (dim1,dim2), & + data%xtts (dim1,dim2), & + data%xzts (dim1,dim2), & + data%dt_cool (dim1,dim2), & + data%z_c (dim1,dim2), & + data%c_0 (dim1,dim2), & + data%c_d (dim1,dim2), & + data%w_0 (dim1,dim2), & + data%w_d (dim1,dim2), & + data%d_conv (dim1,dim2), & + data%ifd (dim1,dim2), & + data%tref (dim1,dim2), & + data%qrain (dim1,dim2), & + stat=iret) + if(iret/=0) iret=-3 + return + end subroutine nstvar_aldata - END MODULE Nst_Var_ESMFMod + end module nst_var_esmfmod diff --git a/src/gsi/nstio_module.f90 b/src/gsi/nstio_module.f90 index dc0c97ffc1..8e58de3717 100644 --- a/src/gsi/nstio_module.f90 +++ b/src/gsi/nstio_module.f90 @@ -2,20 +2,20 @@ module nstio_module !$$$ Module Documentation Block ! -! Module: nstio_module API for global spectral nst file I/O +! Module: nstio_module api for global spectral nst file i/o ! Prgmmr: Xu Li (modified from sfcio_modul) Org: w/nx23 date: 2007-10-26 ! -! Abstract: This module provides an Application Program Interface -! for performing I/O on the nst restart file of the global nst diurnal warming and sub-layer cooling models. +! Abstract: This module provides an application program interface +! for performing i/o on the nst restart file of the global nst diurnal warming and sub-layer cooling models. ! Functions include opening, reading, writing, and closing as well as ! allocating and deallocating data buffers sed in the transfers. -! The I/O performed here is sequential. +! The i/o performed here is sequential. ! The transfers are limited to header records or data records. ! ! Program History Log: ! 2007-10-26 Xu Li ! 2008-03-25 Xu Li: add surface mask field -! 2009-06-30 Xu Li: modified for NCEP DTM-1p +! 2009-06-30 Xu Li: modified for ncep dtm-1p ! ! Public Variables: ! nstio_lhead1 Integer parameter length of first header record (=32) @@ -27,7 +27,7 @@ module nstio_module ! ! Public Defined Types: ! nstio_head nst file header information -! clabnst Character(nstio_lhead1) ON85 label +! clabnst Character(nstio_lhead1) on85 label ! fhour Real(nstio_realkind) forecast hour ! idate Integer(nstio_intkind)(4) initial date ! (hour, month, day, 4-digit year) @@ -44,41 +44,41 @@ module nstio_module ! slmsk Real(nstio_realkind)(:,:) pointer to lonb*latb ! surface mask: 0 = water; 1 = land; 2 = ice ! xt Real(nstio_realkind)(:,:) pointer to lonb*latb -! heat content in DTL (M*K) +! heat content in dtl (m*k) ! xs Real(nstio_realkind)(:,:) pointer to lonb*latb -! salinity content in DTL (M*ppt) +! salinity content in dtl (m*ppt) ! xu Real(nstio_realkind)(:,:) pointer to lonb*latb -! u-current content in DTL (M*M/S) +! u-current content in dtl (m*m/s) ! xv Real(nstio_realkind)(:,:) pointer to lonb*latb -! v-current content in DTL (M*M/S) +! v-current content in dtl (m*m/s) ! xz Real(nstio_realkind)(:,:) pointer to lonb*latb -! DTL thickness (M) +! dtl thickness (m) ! zm Real(nstio_realkind)(:,:) pointer to lonb*latb -! MXL thickness (M) +! mxl thickness (m) ! xtts Real(nstio_realkind)(:,:) pointer to lonb*latb -! d(xt)/d(Ts) (1/M) +! d(xt)/d(ts) (1/m) ! xzts Real(nstio_realkind)(:,:) pointer to lonb*latb -! d(xz)/d(Ts) (M/K) +! d(xz)/d(ts) (m/k) ! dt_cool Real(nstio_realkind)(:,:) pointer to lonb*latb ! sea surface cooling amount by sub-layer cooling effect ! z_c Real(nstio_realkind)(:,:) pointer to lonb*latb ! sea sub-layer depth in m ! c_0 Real(nstio_realkind)(:,:) pointer to lonb*latb -! coefficient to calculate d(Tz)/d(tr) in dimensionless +! coefficient to calculate d(tz)/d(tr) in dimensionless ! c_d Real(nstio_realkind)(:,:) pointer to lonb*latb -! coefficient to calculate d(Tz)/d(tr) in (1/M) +! coefficient to calculate d(tz)/d(tr) in (1/m) ! w_0 Real(nstio_realkind)(:,:) pointer to lonb*latb -! coefficient to calculate d(Tz)/d(tr) in dimensionless +! coefficient to calculate d(tz)/d(tr) in dimensionless ! w_d Real(nstio_realkind)(:,:) pointer to lonb*latb -! coefficient to calculate d(Tz)/d(tr) (1/M) +! coefficient to calculate d(tz)/d(tr) (1/m) ! d_conv Real(nstio_realkind)(:,:) pointer to lonb*latb -! FCL thickness (M) +! fcl thickness (m) ! ifd Real(nstio_realkind)(:,:) pointer to lonb*latb ! index of time integral started mode: 0 = not yet; 1 = started already -! Tref Real(nstio_realkind)(:,:) pointer to lonb*latb -! reference temperature (K) -! Qrain Real(nstio_realkind)(:,:) pointer to lonb*latb -! sensible heat flux due to rainfall (W*M^-2) +! tref Real(nstio_realkind)(:,:) pointer to lonb*latb +! reference temperature (k) +! qrain Real(nstio_realkind)(:,:) pointer to lonb*latb +! sensible heat flux due to rainfall (w*m^-2) ! ! nstio_dbta nst file longreal data fields ! @@ -93,16 +93,16 @@ module nstio_module ! cfname Character(*) input filename ! iret Integer(nstio_intkind) output return code ! -! nstio_srclose Close nst file for sequential I/O +! nstio_srclose Close nst file for sequential i/o ! lu Integer(nstio_intkind) input logical unit ! iret Integer(nstio_intkind) output return code ! -! nstio_srhead Read header information with sequential I/O +! nstio_srhead Read header information with sequential i/o ! lu Integer(nstio_intkind) input logical unit ! head Type(nstio_head) output header information ! iret Integer(nstio_intkind) output return code ! -! nstio_swhead Write header information with sequential I/O +! nstio_swhead Write header information with sequential i/o ! lu Integer(nstio_intkind) input logical unit ! head Type(nstio_head) input header information ! iret Integer(nstio_intkind) output return code @@ -122,26 +122,26 @@ module nstio_module ! data Type(nstio_data) output data fields ! iret Integer(nstio_intkind) output return code ! -! nstio_srdata Read data fields with sequential I/O +! nstio_srdata Read data fields with sequential i/o ! lu Integer(nstio_intkind) input logical unit ! head Type(nstio_head) input header information ! data Type(nstio_data) output data fields ! iret Integer(nstio_intkind) output return code ! -! nstio_swdata Write data fields with sequential I/O +! nstio_swdata Write data fields with sequential i/o ! lu Integer(nstio_intkind) input logical unit ! head Type(nstio_head) input header information ! data Type(nstio_data) input data fields ! iret Integer(nstio_intkind) output return code ! -! nstio_srohdc Open, read header & data and close with sequential I/O +! nstio_srohdc Open, read header & data and close with sequential i/o ! lu Integer(nstio_intkind) input logical unit ! cfname Character(*) input filename ! head Type(nstio_head) output header information ! data Type(nstio_data) output data fields ! iret Integer(nstio_intkind) output return code ! -! nstio_swohdc Open, write header & data and close with sequential I/O +! nstio_swohdc Open, write header & data and close with sequential i/o ! lu Integer(nstio_intkind) input logical unit ! cfname Character(*) input filename ! head Type(nstio_head) input header information @@ -157,13 +157,13 @@ module nstio_module ! dbta Type(nstio_dbta) output longreal data fields ! iret Integer(nstio_intkind) output return code ! -! nstio_srdbta Read longreal data fields with sequential I/O +! nstio_srdbta Read longreal data fields with sequential i/o ! lu Integer(nstio_intkind) input logical unit ! head Type(nstio_head) input header information ! dbta Type(nstio_dbta) output longreal data fields ! iret Integer(nstio_intkind) output return code ! -! nstio_swdbta Write longreal data fields with sequential I/O +! nstio_swdbta Write longreal data fields with sequential i/o ! lu Integer(nstio_intkind) input logical unit ! head Type(nstio_head) input header information ! dbta Type(nstio_dbta) input longreal data fields @@ -198,15 +198,15 @@ module nstio_module ! w_d (lonb*latb 4-byte words) ! d_conv (lonb*latb 4-byte words) ! ifd (lonb*latb 4-byte words) -! Tref (lonb*latb 4-byte words) -! Qrain (lonb*latb 4-byte words) +! tref (lonb*latb 4-byte words) +! qrain (lonb*latb 4-byte words) ! ! (2) Possible return codes: ! 0 Successful call -! -1 Open or close I/O error -! -2 Header record I/O error or unrecognized version +! -1 Open or close i/o error +! -2 Header record i/o error or unrecognized version ! -3 Allocation or deallocation error -! -4 Data record I/O error +! -4 Data record i/o error ! -5 Insufficient data dimensions allocated ! ! Examples: @@ -224,78 +224,79 @@ module nstio_module ! Language: Fortran 90 ! !$$$ + use kinds, only: i_kind implicit none private ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! Public Variables - integer,parameter,public:: ngrids_nst=19 - integer,parameter,public:: nstio_lhead1=32 - integer,parameter,public:: nstio_intkind=4,nstio_realkind=4,nstio_dblekind=8 - real(nstio_realkind),parameter,public:: nstio_realfill=-9999. - real(nstio_dblekind),parameter,public:: nstio_dblefill=nstio_realfill +! Public variables + integer(i_kind),parameter,public:: ngrids_nst=19 + integer(i_kind),parameter,public:: nstio_lhead1=32 + integer(i_kind),parameter,public:: nstio_intkind=4,nstio_realkind=4,nstio_dblekind=8 + real(nstio_realkind),parameter,public:: nstio_realfill=-9999._nstio_realkind + real(nstio_dblekind),parameter,public:: nstio_dblefill=-9999._nstio_dblekind ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! Public Types +! Public types type,public:: nstio_head - character(nstio_lhead1):: clabnst=' ' - real(nstio_realkind):: fhour=0. - integer(nstio_intkind):: idate(4)=(/0,0,0,0/),latb=0,lonb=0,lsea=0,ivo=0 - integer(nstio_intkind):: irealf=1 - integer(nstio_intkind),allocatable:: lpl(:) - real(nstio_realkind),allocatable:: zsea(:) + character(nstio_lhead1):: clabnst=' ' + real(nstio_realkind):: fhour=0. + integer(nstio_intkind):: idate(4)=(/0,0,0,0/),latb=0,lonb=0,lsea=0,ivo=0 + integer(nstio_intkind):: irealf=1 + integer(nstio_intkind),allocatable:: lpl(:) + real(nstio_realkind),allocatable:: zsea(:) end type type,public:: nstio_data - real(nstio_realkind),pointer:: slmsk (:,:)=>null() - real(nstio_realkind),pointer:: xt (:,:)=>null() - real(nstio_realkind),pointer:: xs (:,:)=>null() - real(nstio_realkind),pointer:: xu (:,:)=>null() - real(nstio_realkind),pointer:: xv (:,:)=>null() - real(nstio_realkind),pointer:: xz (:,:)=>null() - real(nstio_realkind),pointer:: zm (:,:)=>null() - real(nstio_realkind),pointer:: xtts (:,:)=>null() - real(nstio_realkind),pointer:: xzts (:,:)=>null() - real(nstio_realkind),pointer:: dt_cool (:,:)=>null() - real(nstio_realkind),pointer:: z_c (:,:)=>null() - real(nstio_realkind),pointer:: c_0 (:,:)=>null() - real(nstio_realkind),pointer:: c_d (:,:)=>null() - real(nstio_realkind),pointer:: w_0 (:,:)=>null() - real(nstio_realkind),pointer:: w_d (:,:)=>null() - real(nstio_realkind),pointer:: d_conv (:,:)=>null() - real(nstio_realkind),pointer:: ifd (:,:)=>null() - real(nstio_realkind),pointer:: tref (:,:)=>null() - real(nstio_realkind),pointer:: Qrain (:,:)=>null() + real(nstio_realkind),pointer:: slmsk (:,:)=>null() + real(nstio_realkind),pointer:: xt (:,:)=>null() + real(nstio_realkind),pointer:: xs (:,:)=>null() + real(nstio_realkind),pointer:: xu (:,:)=>null() + real(nstio_realkind),pointer:: xv (:,:)=>null() + real(nstio_realkind),pointer:: xz (:,:)=>null() + real(nstio_realkind),pointer:: zm (:,:)=>null() + real(nstio_realkind),pointer:: xtts (:,:)=>null() + real(nstio_realkind),pointer:: xzts (:,:)=>null() + real(nstio_realkind),pointer:: dt_cool (:,:)=>null() + real(nstio_realkind),pointer:: z_c (:,:)=>null() + real(nstio_realkind),pointer:: c_0 (:,:)=>null() + real(nstio_realkind),pointer:: c_d (:,:)=>null() + real(nstio_realkind),pointer:: w_0 (:,:)=>null() + real(nstio_realkind),pointer:: w_d (:,:)=>null() + real(nstio_realkind),pointer:: d_conv (:,:)=>null() + real(nstio_realkind),pointer:: ifd (:,:)=>null() + real(nstio_realkind),pointer:: tref (:,:)=>null() + real(nstio_realkind),pointer:: qrain (:,:)=>null() end type type,public:: nstio_dbta - real(nstio_dblekind),pointer:: slmsk (:,:)=>null() - real(nstio_dblekind),pointer:: xt (:,:)=>null() - real(nstio_dblekind),pointer:: xs (:,:)=>null() - real(nstio_dblekind),pointer:: xu (:,:)=>null() - real(nstio_dblekind),pointer:: xv (:,:)=>null() - real(nstio_dblekind),pointer:: xz (:,:)=>null() - real(nstio_dblekind),pointer:: zm (:,:)=>null() - real(nstio_dblekind),pointer:: xtts (:,:)=>null() - real(nstio_dblekind),pointer:: xzts (:,:)=>null() - real(nstio_dblekind),pointer:: dt_cool (:,:)=>null() - real(nstio_dblekind),pointer:: z_c (:,:)=>null() - real(nstio_dblekind),pointer:: c_0 (:,:)=>null() - real(nstio_dblekind),pointer:: c_d (:,:)=>null() - real(nstio_dblekind),pointer:: w_0 (:,:)=>null() - real(nstio_dblekind),pointer:: w_d (:,:)=>null() - real(nstio_dblekind),pointer:: d_conv (:,:)=>null() - real(nstio_dblekind),pointer:: ifd (:,:)=>null() - real(nstio_dblekind),pointer:: tref (:,:)=>null() - real(nstio_dblekind),pointer:: Qrain (:,:)=>null() + real(nstio_dblekind),pointer:: slmsk (:,:)=>null() + real(nstio_dblekind),pointer:: xt (:,:)=>null() + real(nstio_dblekind),pointer:: xs (:,:)=>null() + real(nstio_dblekind),pointer:: xu (:,:)=>null() + real(nstio_dblekind),pointer:: xv (:,:)=>null() + real(nstio_dblekind),pointer:: xz (:,:)=>null() + real(nstio_dblekind),pointer:: zm (:,:)=>null() + real(nstio_dblekind),pointer:: xtts (:,:)=>null() + real(nstio_dblekind),pointer:: xzts (:,:)=>null() + real(nstio_dblekind),pointer:: dt_cool (:,:)=>null() + real(nstio_dblekind),pointer:: z_c (:,:)=>null() + real(nstio_dblekind),pointer:: c_0 (:,:)=>null() + real(nstio_dblekind),pointer:: c_d (:,:)=>null() + real(nstio_dblekind),pointer:: w_0 (:,:)=>null() + real(nstio_dblekind),pointer:: w_d (:,:)=>null() + real(nstio_dblekind),pointer:: d_conv (:,:)=>null() + real(nstio_dblekind),pointer:: ifd (:,:)=>null() + real(nstio_dblekind),pointer:: tref (:,:)=>null() + real(nstio_dblekind),pointer:: qrain (:,:)=>null() end type ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! Public Subprograms +! Public subprograms public nstio_sropen,nstio_swopen,nstio_srclose,nstio_srhead,nstio_swhead public nstio_alhead,nstio_aldata,nstio_axdata,nstio_srdata,nstio_swdata public nstio_aldbta,nstio_axdbta,nstio_srdbta,nstio_swdbta public nstio_srohdc,nstio_swohdc interface nstio_srohdc - module procedure nstio_srohdca,nstio_srohdcb + module procedure nstio_srohdca,nstio_srohdcb end interface interface nstio_swohdc - module procedure nstio_swohdca,nstio_swohdcb + module procedure nstio_swohdca,nstio_swohdcb end interface contains !------------------------------------------------------------------------------- @@ -304,13 +305,13 @@ subroutine nstio_sropen(lu,cfname,iret) integer(nstio_intkind),intent(in):: lu character*(*),intent(in):: cfname integer(nstio_intkind),intent(out):: iret - integer ios + integer(i_kind) ios ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - open(lu,file=cfname,form='unformatted',& status='old',action='read',iostat=ios) ! write(*,*) ' successfully opened : ',cfname, ios iret=ios - if(iret.ne.0) iret=-1 + if(iret/=0) iret=-1 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine !------------------------------------------------------------------------------- @@ -319,12 +320,12 @@ subroutine nstio_swopen(lu,cfname,iret) integer(nstio_intkind),intent(in):: lu character*(*),intent(in):: cfname integer(nstio_intkind),intent(out):: iret - integer ios + integer(i_kind) ios ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - open(lu,file=cfname,form='unformatted',& status='unknown',action='readwrite',iostat=ios) iret=ios - if(iret.ne.0) iret=-1 + if(iret/=0) iret=-1 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine !------------------------------------------------------------------------------- @@ -332,11 +333,11 @@ subroutine nstio_srclose(lu,iret) implicit none integer(nstio_intkind),intent(in):: lu integer(nstio_intkind),intent(out):: iret - integer ios + integer(i_kind) ios ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - close(lu,iostat=ios) iret=ios - if(iret.ne.0) iret=-1 + if(iret/=0) iret=-1 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine !------------------------------------------------------------------------------- @@ -345,7 +346,7 @@ subroutine nstio_srhead(lu,head,iret) integer(nstio_intkind),intent(in):: lu type(nstio_head),intent(out):: head integer(nstio_intkind),intent(out):: iret - integer:: ios + integer(i_kind):: ios character(4):: cgfs,cnst integer(nstio_intkind):: nhead,nresv(3) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -353,27 +354,27 @@ subroutine nstio_srhead(lu,head,iret) rewind lu read(lu,iostat=ios) head%clabnst(1:8) ! write(*,*) ' head%clabnst done, ios : ',head%clabnst(1:8), ios - if(ios.ne.0) return - if(head%clabnst(1:8).eq.'GFS NST ') then ! modern nst file - rewind lu - read(lu,iostat=ios) cgfs,cnst,head%ivo,nhead,nresv -! write(*,*) ' cgfs,cnst done, ios : ',cgfs,cnst, ios,head%ivo,nhead - if(ios.ne.0) return - if(head%ivo.eq.200907) then - read(lu,iostat=ios) - if(ios.ne.0) return - read(lu,iostat=ios) head%fhour,head%idate,head%lonb,head%latb,& - head%lsea,head%irealf - if(ios.ne.0) return - call nstio_alhead(head,ios) - if(ios.ne.0) return - read(lu,iostat=ios) head%lpl - if(ios.ne.0) return - read(lu,iostat=ios) head%zsea - if(ios.ne.0) return - else - return - endif + if(ios/=0) return + if(head%clabnst(1:8)=='GFS NST ') then ! modern nst file + rewind lu + read(lu,iostat=ios) cgfs,cnst,head%ivo,nhead,nresv +! write(*,*) ' cgfs,cnst done, ios : ',cgfs,cnst, ios,head%ivo,nhead + if(ios/=0) return + if(head%ivo==200907) then + read(lu,iostat=ios) + if(ios/=0) return + read(lu,iostat=ios) head%fhour,head%idate,head%lonb,head%latb,& + head%lsea,head%irealf + if(ios/=0) return + call nstio_alhead(head,ios) + if(ios/=0) return + read(lu,iostat=ios) head%lpl + if(ios/=0) return + read(lu,iostat=ios) head%zsea + if(ios/=0) return + else + return + endif endif iret=0 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -384,26 +385,26 @@ subroutine nstio_swhead(lu,head,iret) integer(nstio_intkind),intent(in):: lu type(nstio_head),intent(in):: head integer(nstio_intkind),intent(out):: iret - integer:: ios - integer i + integer(i_kind):: ios + integer(i_kind) i ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - iret=-2 - if(head%ivo.eq.200907) then - rewind lu - write(lu,iostat=ios) 'GFS NST ',head%ivo,ngrids_nst+4*head%lsea,0,0,0 - if(ios.ne.0) return - write(lu,iostat=ios) 4*(/8,ngrids_nst+4*head%lsea,25,head%latb/2,head%lsea/),& - 4*head%irealf*(/(head%lonb*head%latb,& - i=1,ngrids_nst+4*head%lsea)/) - if(ios.ne.0) return - write(lu,iostat=ios) head%fhour,head%idate,head%lonb,head%latb,& - head%lsea,head%irealf,(0,i=1,16) - if(ios.ne.0) return - write(lu,iostat=ios) head%lpl - if(ios.ne.0) return - write(lu,iostat=ios) head%zsea - if(ios.ne.0) return - iret=0 + if(head%ivo==200907) then + rewind lu + write(lu,iostat=ios) 'GFS NST ',head%ivo,ngrids_nst+4*head%lsea,0,0,0 + if(ios/=0) return + write(lu,iostat=ios) 4*(/8,ngrids_nst+4*head%lsea,25,head%latb/2,head%lsea/),& + 4*head%irealf*(/(head%lonb*head%latb,& + i=1,ngrids_nst+4*head%lsea)/) + if(ios/=0) return + write(lu,iostat=ios) head%fhour,head%idate,head%lonb,head%latb,& + head%lsea,head%irealf,(0,i=1,16) + if(ios/=0) return + write(lu,iostat=ios) head%lpl + if(ios/=0) return + write(lu,iostat=ios) head%zsea + if(ios/=0) return + iret=0 endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine @@ -413,28 +414,28 @@ subroutine nstio_alhead(head,iret,latb,lsea) type(nstio_head),intent(inout):: head integer(nstio_intkind),intent(out):: iret integer(nstio_intkind),optional,intent(in):: latb,lsea - integer dim1l,dim1z + integer(i_kind) dim1l,dim1z ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if(present(latb)) then - dim1l=latb/2 + dim1l=latb/2 else - dim1l=head%latb/2 + dim1l=head%latb/2 endif if(present(lsea)) then - dim1z=lsea + dim1z=lsea else - dim1z=head%lsea + dim1z=head%lsea endif if(allocated(head%lpl)) deallocate(head%lpl) if(allocated(head%zsea)) deallocate(head%zsea) allocate(head%lpl(dim1l),head%zsea(dim1z),stat=iret) - if(iret.eq.0) then - head%lpl=0 - head%zsea=nstio_realfill + if(iret==0) then + head%lpl=0 + head%zsea=nstio_realfill endif - if(iret.ne.0) then - iret=-3 - write(*,*) ' fail to allocate nstio%head, iret = ',iret + if(iret/=0) then + iret=-3 + write(*,*) ' fail to allocate nstio%head, iret = ',iret endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine @@ -444,7 +445,7 @@ subroutine nstio_aldata(head,data,iret) type(nstio_head),intent(in):: head type(nstio_data),intent(inout):: data integer(nstio_intkind),intent(out):: iret - integer dim1,dim2,dim3 + integer(i_kind) dim1,dim2,dim3 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call nstio_axdata(data,iret) dim1=head%lonb @@ -452,29 +453,29 @@ subroutine nstio_aldata(head,data,iret) dim3=head%lsea ! write(*,*) 'in nstio_aldata, dim1, dim2, dim3 : ', dim1, dim2, dim3 allocate(& - data%slmsk(dim1,dim2),& - data%xt(dim1,dim2),& - data%xs(dim1,dim2),& - data%xu(dim1,dim2),& - data%xv(dim1,dim2),& - data%xz(dim1,dim2),& - data%zm(dim1,dim2),& - data%xtts(dim1,dim2),& - data%xzts(dim1,dim2),& - data%dt_cool(dim1,dim2),& - data%z_c(dim1,dim2),& - data%c_0(dim1,dim2),& - data%c_d(dim1,dim2),& - data%w_0(dim1,dim2),& - data%w_d(dim1,dim2),& - data%d_conv(dim1,dim2),& - data%ifd(dim1,dim2),& - data%tref(dim1,dim2),& - data%Qrain(dim1,dim2),& - stat=iret) - if(iret.ne.0) then - iret=-3 - write(*,*) ' fail to allocate nstio%data, iret = ',iret + data%slmsk(dim1,dim2),& + data%xt(dim1,dim2),& + data%xs(dim1,dim2),& + data%xu(dim1,dim2),& + data%xv(dim1,dim2),& + data%xz(dim1,dim2),& + data%zm(dim1,dim2),& + data%xtts(dim1,dim2),& + data%xzts(dim1,dim2),& + data%dt_cool(dim1,dim2),& + data%z_c(dim1,dim2),& + data%c_0(dim1,dim2),& + data%c_d(dim1,dim2),& + data%w_0(dim1,dim2),& + data%w_d(dim1,dim2),& + data%d_conv(dim1,dim2),& + data%ifd(dim1,dim2),& + data%tref(dim1,dim2),& + data%qrain(dim1,dim2),& + stat=iret) + if(iret/=0) then + iret=-3 + write(*,*) ' fail to allocate nstio%data, iret = ',iret endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine @@ -485,47 +486,47 @@ subroutine nstio_axdata(data,iret) integer(nstio_intkind),intent(out):: iret ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - deallocate(& - data%slmsk,& - data%xt,& - data%xs,& - data%xu,& - data%xv,& - data%xz,& - data%zm,& - data%xtts,& - data%xzts,& - data%dt_cool,& - data%z_c,& - data%c_0,& - data%c_d,& - data%w_0,& - data%w_d,& - data%d_conv,& - data%ifd,& - data%tref,& - data%Qrain,& - stat=iret) + data%slmsk,& + data%xt,& + data%xs,& + data%xu,& + data%xv,& + data%xz,& + data%zm,& + data%xtts,& + data%xzts,& + data%dt_cool,& + data%z_c,& + data%c_0,& + data%c_d,& + data%w_0,& + data%w_d,& + data%d_conv,& + data%ifd,& + data%tref,& + data%qrain,& + stat=iret) nullify(& - data%slmsk,& - data%xt,& - data%xs,& - data%xu,& - data%xv,& - data%xz,& - data%zm,& - data%xtts,& - data%xzts,& - data%dt_cool,& - data%z_c,& - data%c_0,& - data%c_d,& - data%w_0,& - data%w_d,& - data%d_conv,& - data%ifd,& - data%tref,& - data%Qrain) - if(iret.ne.0) iret=-3 + data%slmsk,& + data%xt,& + data%xs,& + data%xu,& + data%xv,& + data%xz,& + data%zm,& + data%xtts,& + data%xzts,& + data%dt_cool,& + data%z_c,& + data%c_0,& + data%c_d,& + data%w_0,& + data%w_d,& + data%d_conv,& + data%ifd,& + data%tref,& + data%qrain) + if(iret/=0) iret=-3 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine !------------------------------------------------------------------------------- @@ -535,8 +536,8 @@ subroutine nstio_srdata(lu,head,data,iret) type(nstio_head),intent(in):: head type(nstio_data),intent(inout):: data integer(nstio_intkind),intent(out):: iret - integer:: dim1,dim2,dim3,mdim1,mdim2,mdim3 - integer:: ios + integer(i_kind):: dim1,dim2,dim3,mdim1,mdim2,mdim3 + integer(i_kind):: ios type(nstio_dbta) dbta ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - dim1=head%lonb @@ -544,118 +545,118 @@ subroutine nstio_srdata(lu,head,data,iret) dim3=head%lsea mdim1=min(& - size(data%slmsk,1),& - size(data%xt,1),& - size(data%xs,1),& - size(data%xu,1),& - size(data%xv,1),& - size(data%xz,1),& - size(data%zm,1),& - size(data%xtts,1),& - size(data%xzts,1),& - size(data%dt_cool,1),& - size(data%z_c,1),& - size(data%c_0,1),& - size(data%c_d,1),& - size(data%w_0,1),& - size(data%w_d,1),& - size(data%d_conv,1),& - size(data%ifd,1),& - size(data%tref,1),& - size(data%Qrain,1)) + size(data%slmsk,1),& + size(data%xt,1),& + size(data%xs,1),& + size(data%xu,1),& + size(data%xv,1),& + size(data%xz,1),& + size(data%zm,1),& + size(data%xtts,1),& + size(data%xzts,1),& + size(data%dt_cool,1),& + size(data%z_c,1),& + size(data%c_0,1),& + size(data%c_d,1),& + size(data%w_0,1),& + size(data%w_d,1),& + size(data%d_conv,1),& + size(data%ifd,1),& + size(data%tref,1),& + size(data%qrain,1)) mdim2=min(& - size(data%slmsk,2),& - size(data%xt,2),& - size(data%xs,2),& - size(data%xu,2),& - size(data%xv,2),& - size(data%xz,2),& - size(data%zm,2),& - size(data%xtts,2),& - size(data%xzts,2),& - size(data%dt_cool,2),& - size(data%z_c,2),& - size(data%c_0,2),& - size(data%c_d,2),& - size(data%w_0,2),& - size(data%w_d,2),& - size(data%d_conv,2),& - size(data%ifd,2),& - size(data%tref,2),& - size(data%Qrain,2)) + size(data%slmsk,2),& + size(data%xt,2),& + size(data%xs,2),& + size(data%xu,2),& + size(data%xv,2),& + size(data%xz,2),& + size(data%zm,2),& + size(data%xtts,2),& + size(data%xzts,2),& + size(data%dt_cool,2),& + size(data%z_c,2),& + size(data%c_0,2),& + size(data%c_d,2),& + size(data%w_0,2),& + size(data%w_d,2),& + size(data%d_conv,2),& + size(data%ifd,2),& + size(data%tref,2),& + size(data%qrain,2)) mdim3=0 iret=-5 - if(mdim1.lt.dim1.or.& - mdim2.lt.dim2.or.& - mdim3.lt.dim3) return + if(mdim11) then else - ! If requested and if available, read guess solution. + ! If requested and if available, read guess solution. endif ! Generate coefficients for compact differencing @@ -231,18 +229,18 @@ subroutine init_ use mpeu_util,only : tell, die use gsi_io, only : verbose implicit none - character(len=*),parameter:: Iam='observer_init' + character(len=*),parameter:: iam='observer_init' logical :: print_verbose ! Declare passed variables ! Declare local variables -_ENTRY_(Iam) +_ENTRY_(iam) print_verbose=.false. if(verbose)print_verbose=.true. - if(ob_initialized_) call die(Iam,'already initialized') + if(ob_initialized_) call die(iam,'already initialized') ob_initialized_=.true. iamset_ = .false. @@ -263,9 +261,9 @@ subroutine init_ call tell('observer.init_','guess_init_()') end if -! ndata(*,1)- number of prefiles retained for further processing -! ndata(*,2)- number of observations read -! ndata(*,3)- number of observations keep after read +! ndata(*,1)- number of prefiles retained for further processing +! ndata(*,2)- number of observations read +! ndata(*,3)- number of observations keep after read if(print_verbose)then call tell('observer.init_','ndat =',ndat) end if @@ -274,10 +272,10 @@ subroutine init_ call tell('observer.init_','allocate(ndata)') call tell('observer.init_','exiting') end if - if(print_verbose .and. mype==0) write(6,*) Iam, ': successfully initialized' + if(print_verbose .and. mype==0) write(6,*) iam, ': successfully initialized' ! End of routine call timer_fnl('observer.init_') -_EXIT_(Iam) +_EXIT_(iam) end subroutine init_ subroutine set_ @@ -310,7 +308,7 @@ subroutine set_ use mpeu_util, only: tell,die use gsi_io, only: mype_io implicit none - character(len=*), parameter :: Iam="observer_set" + character(len=*), parameter :: iam="observer_set" ! Declare passed variables @@ -319,12 +317,12 @@ subroutine set_ integer(i_kind):: lunsave,istat1,istat2,istat3,ndat_old,npe_old data lunsave / 22 / -_ENTRY_(Iam) +_ENTRY_(iam) !******************************************************************************************* call timer_ini('observer.set_') - if ( iamset_ ) call die(Iam,'already set') + if ( iamset_ ) call die(iam,'already set') ! Create file names for pe relative observation data. obs_setup files are used ! in outer loop setup routines. @@ -342,7 +340,7 @@ subroutine set_ inquire(file=obs_input_common,exist=lhere) if (.not.lhere) then if (mype==0) write(6,*)'OBSERVER_SET: ***ERROR*** file ',& - trim(obs_input_common),' does NOT exist. Terminate execution' + trim(obs_input_common),' does NOT exist. Terminate execution' call stop2(329) endif @@ -353,12 +351,12 @@ subroutine set_ read(lunsave,iostat=istat2) super_val1 if (istat1/=0 .or. istat2/=0) then if (mype==0) write(6,*)'OBSERVER_SET: ***ERROR*** reading file ',& - trim(obs_input_common),' istat1,istat2=',istat1,istat2,' Terminate execution' + trim(obs_input_common),' istat1,istat2=',istat1,istat2,' Terminate execution' call stop2(329) endif if(npe_old /= npe .or. ndat /= ndat_old) then if (mype==0) write(6,*) ' observer_set: inconsistent ndat,npe ',ndat,npe, & - ' /= ',ndat_old,npe_old + ' /= ',ndat_old,npe_old call stop2(330) end if read(lunsave,iostat=istat3) nobs_sub @@ -385,7 +383,7 @@ subroutine set_ ! End of routine call timer_fnl('observer.set_') -_EXIT_(Iam) +_EXIT_(iam) end subroutine set_ subroutine run_(init_pass,last_pass) @@ -423,7 +421,7 @@ subroutine run_(init_pass,last_pass) ! Declare passed variables ! Declare local variables - character(len=*), parameter :: Iam="observer_run" + character(len=*), parameter :: iam="observer_run" integer(i_kind) jiterlast logical :: last @@ -432,7 +430,7 @@ subroutine run_(init_pass,last_pass) logical :: last_pass_ logical :: print_verbose -_ENTRY_(Iam) +_ENTRY_(iam) print_verbose=.false. if(verbose)print_verbose=.true. call timer_ini('observer.run_') @@ -442,11 +440,11 @@ subroutine run_(init_pass,last_pass) if(present(last_pass)) last_pass_= last_pass if(print_verbose)then - call tell(Iam,'init_pass =',init_pass_) - call tell(Iam,'last_pass =',last_pass_) + call tell(iam,'init_pass =',init_pass_) + call tell(iam,'last_pass =',last_pass_) end if - if(.not.ob_initialized_) call die(Iam,'not initialized') + if(.not.ob_initialized_) call die(iam,'not initialized') !******************************************************************************************* @@ -461,9 +459,9 @@ subroutine run_(init_pass,last_pass) call stop2(157) endif if(mype==0 .and. print_verbose) then - call tell(Iam,'miter =',miter) - call tell(Iam,'jiterstart =',jiterstart) - call tell(Iam,'jiterlast =',jiterlast ) + call tell(iam,'miter =',miter) + call tell(iam,'jiterstart =',jiterstart) + call tell(iam,'jiterlast =',jiterlast ) endif if (mype==0) write(6,*)'OBSERVER: jiterstart,jiterlast=',jiterstart,jiterlast @@ -494,7 +492,7 @@ subroutine run_(init_pass,last_pass) call timer_fnl('observer.run_') ! End of routine -_EXIT_(Iam) +_EXIT_(iam) end subroutine run_ subroutine final_ @@ -530,16 +528,16 @@ subroutine final_ ! Declare passed variables ! Declare local variables - character(len=*),parameter:: Iam="observer_final" + character(len=*),parameter:: iam="observer_final" logical print_verbose !******************************************************************************************* -_ENTRY_(Iam) +_ENTRY_(iam) call timer_ini('observer.final_') print_verbose=.false. if(verbose) print_verbose=.true. - if(.not.ob_initialized_) call die(Iam,'not initialized') + if(.not.ob_initialized_) call die(iam,'not initialized') ob_initialized_=.false. if (tendsflag) then @@ -557,14 +555,14 @@ subroutine final_ call convinfo_destroy deallocate(ndata) - if(mype==0 .and. print_verbose) write(6,*) Iam, ': successfully finalized' + if(mype==0 .and. print_verbose) write(6,*) iam, ': successfully finalized' ! Finalize timer for this procedure call timer_fnl('observer.final_') call timer_fnl('observer') ! End of routine -_EXIT_(Iam) +_EXIT_(iam) end subroutine final_ subroutine guess_final_