!------------------------------------------------------------------------------- module sigio_module !$$$ Module Documentation Block ! ! Module: sigio_module API for global spectral sigma file I/O ! Prgmmr: iredell Org: w/nx23 date: 1999-01-18 ! ! Abstract: This module provides an Application Program Interface ! for performing I/O on the sigma restart file of the global spectral model. ! Functions include opening, reading, writing, and closing as well as ! allocating and deallocating data buffers used in the transfers. ! The I/O performed here is sequential. ! The transfers are limited to header records or data records. ! ! Program History Log: ! 1999-01-18 Mark Iredell ! 2013-10-14 Fanglin Yang: Added dynamics restart fields (ixga etc) ! and restructureed physics restart fields (ixgr etc). ! ! Public Variables: ! sigio_lhead1 Integer parameter length of first header record (=32) ! sigio_charkind Integer parameter kind or length of passed characters (=8) ! sigio_intkind Integer parameter kind or length of passed integers (=4) ! sigio_realkind Integer parameter kind or length of passed reals (=4) ! sigio_dblekind Integer parameter kind or length of passed longreals (=8) ! sigio_realfill Real(sigio_realkind) parameter fill value (=-9999.) ! sigio_dblefill Real(sigio_dblekind) parameter fill value (=-9999.) ! ! Public Defined Types: ! sigio_head Sigma file header information ! clabsig Character(sigio_lhead1) ON85 label ! (obsolescent) ! fhour Real(sigio_realkind) forecast hour ! idate Integer(sigio_intkind)(4) initial date ! (hour, month, day, 4-digit year) ! si Real(sigio_realkind)(101) sigma interfaces ! (obsolescent) ! sl Real(sigio_realkind)(100) sigma levels ! (obsolescent) ! ak Real(sigio_realkind)(101) hybrid interface a ! (obsolescent) ! bk Real(sigio_realkind)(101) hybrid interface b ! (obsolescent) ! jcap Integer(sigio_intkind) spectral truncation ! levs Integer(sigio_intkind) number of levels ! itrun Integer(sigio_intkind) truncation flag ! (=1 for triangular) ! iorder Integer(sigio_intkind) coefficient order flag ! (=2 for ibm order) ! irealf Integer(sigio_intkind) floating point flag ! (=1 for 4-byte ieee, =2 for 8-byte ieee) ! igen Integer(sigio_intkind) model generating flag ! latf Integer(sigio_intkind) latitudes in dynamics ! (=(jcap+1)*3/2) ! lonf Integer(sigio_intkind) longitudes in dynamics ! (>=(jcap+1)*3 appropriate for fft) ! latb Integer(sigio_intkind) latitudes in physics ! lonb Integer(sigio_intkind) longitudes in physics ! latr Integer(sigio_intkind) latitudes in radiation ! lonr Integer(sigio_intkind) longitudes in radiation ! ntrac Integer(sigio_intkind) number of tracers ! icen2 Integer(sigio_intkind) subcenter id ! iens Integer(sigio_intkind)(2) ensemble ids ! idpp Integer(sigio_intkind) processing id ! idsl Integer(sigio_intkind) semi-lagrangian id ! idvc Integer(sigio_intkind) vertical coordinate id ! (=1 for sigma, =2 for ec-hybrid, =3 for ncep hybrid) ! idvm Integer(sigio_intkind) mass variable id ! idvt Integer(sigio_intkind) tracer variable id ! idrun Integer(sigio_intkind) run id ! idusr Integer(sigio_intkind) user-defined id ! pdryini Real(sigio_realkind) global mean dry air pressure (kPa) ! (obsolescent) ! ncldt Integer(sigio_intkind) number of cloud types ! ixgr Integer(sigio_intkind) extra fileds for physics. ! ixgr=00000000 no extra fields ! ixgr=0000000a zhao micro, a=1: zhao1, two 3d, one 2d, and nxss=0 ! a=2: zhao2, four 3d, three 2d, and nxss=0 ! a=3: zhao2, four 3d, three 2d, and nxss=1 ! ixgr=000000b0 ferrier micro, b=1: three 3d, one 2d, and nxss=0 ! ferrier micro, b=2: three 3d, one 2d, and nxss=1 ! ixgr=00000c00 c=1, pdf cld, three 3d ! ixga Integer(sigio_intkind) extra fileds for dynamics. ! ixga=00000000 no extra fields ! ixga=0000000a zflxtvd micro, ntrac 3d, zero 2d ! ixga=000000b0 (reserved for) joe-sela semi-lag gfs ! ivs Integer(sigio_intkind) version number ! nvcoord Integer(sigio_intkind) number of vcoord profiles ! The following variables should be allocated with sigio_alhead: ! vcoord Real(sigio_realkind)((levs+1),nvcoord) vcoord profiles ! cfvars Character(8)(5+ntrac) field variable names ! The following variables should not be modified by the user: ! nxgr Integer(sigio_intkind) number of extra physics grid fields ! nxss Integer(sigio_intkind) number of extra scalars ! nxga Integer(sigio_intkind) number of extra dynamics grid fields ! nhead Integer(sigio_intkind) number of header records ! ndata Integer(sigio_intkind) number of data records ! lhead Integer(sigio_intkind)(nhead) header record lengths ! ldata Integer(sigio_intkind)(ndata) data record lengths ! ! sigio_data Sigma file data fields ! hs Real(sigio_realkind)(:) pointer to spectral ! coefficients of surface height in m ! ps Real(sigio_realkind)(:) pointer to spectral ! coefficients of log of surface pressure over 1 kPa ! t Real(sigio_realkind)(:,:) pointer to spectral ! coefficients of virtual temperature by level in K ! d Real(sigio_realkind)(:,:) pointer to spectral ! coefficients of divergence by level in 1/second ! z Real(sigio_realkind)(:,:) pointer to spectral ! coefficients of vorticity by level in 1/second ! q Real(sigio_realkind)(:,:,:) pointer to spectral ! coefficients of tracers by level and tracer number ! in specific densities ! xgr Real(sigio_realkind)(:,:,:) pointer to extra grid fields ! by longitude, latitude and number of extra physics grid fields ! xss Real(sigio_realkind)(:) pointer to scalar array ! xga Real(sigio_realkind)(:,:,:) pointer to extra dynamics grid fields ! by longitude, latitude and number of extra grid fields ! ! sigio_dbta Sigma file longreal data fields ! hs Real(sigio_dblekind)(:) pointer to spectral ! coefficients of surface height in m ! ps Real(sigio_dblekind)(:) pointer to spectral ! coefficients of log of surface pressure over 1 kPa ! t Real(sigio_dblekind)(:,:) pointer to spectral ! coefficients of virtual temperature by level in K ! d Real(sigio_dblekind)(:,:) pointer to spectral ! coefficients of divergence by level in 1/second ! z Real(sigio_dblekind)(:,:) pointer to spectral ! coefficients of vorticity by level in 1/second ! q Real(sigio_dblekind)(:,:,:) pointer to spectral ! coefficients of tracers by level and tracer number ! in specific densities ! xgr Real(sigio_dblekind)(:,:,:) pointer to extra physics grid fields ! by longitude, latitude and number of extra grid fields ! xss Real(sigio_dblekind)(:) pointer to scalar array ! xga Real(sigio_dblekind)(:,:,:) pointer to extra dynamics grid fields ! by longitude, latitude and number of extra grid fields ! ! Public Subprograms: ! sigio_sropen Open sigma file for sequential reading ! lu Integer(sigio_intkind) input logical unit ! cfname Character(*) input filename ! iret Integer(sigio_intkind) output return code ! ! sigio_swopen Open sigma file for sequential writing ! lu Integer(sigio_intkind) input logical unit ! cfname Character(*) input filename ! iret Integer(sigio_intkind) output return code ! ! sigio_sclose Close sigma file for sequential I/O ! lu Integer(sigio_intkind) input logical unit ! iret Integer(sigio_intkind) output return code ! ! sigio_srhead Read header information with sequential I/O ! lu Integer(sigio_intkind) input logical unit ! head Type(sigio_head) output header information ! iret Integer(sigio_intkind) output return code ! ! sigio_swhead Write header information with sequential I/O ! lu Integer(sigio_intkind) input logical unit ! head Type(sigio_head) input header information ! iret Integer(sigio_intkind) output return code ! ! sigio_alhead Allocate head allocatables ! head Type(sigio_head) input/output header information ! iret Integer(sigio_intkind) output return code ! levs Integer(sigio_intkind) optional number of levels ! nvcoord Integer(sigio_intkind) optional number of vcoords ! ntrac Integer(sigio_intkind) optional number of tracers ! ! sigio_aldata Allocate data fields ! head Type(sigio_head) input header information ! data Type(sigio_data) output data fields ! iret Integer(sigio_intkind) output return code ! ! sigio_axdata Deallocate data fields ! data Type(sigio_data) output data fields ! iret Integer(sigio_intkind) output return code ! ! sigio_srdata Read data fields with sequential I/O ! lu Integer(sigio_intkind) input logical unit ! head Type(sigio_head) input header information ! data Type(sigio_data) output data fields ! iret Integer(sigio_intkind) output return code ! ! sigio_swdata Write data fields with sequential I/O ! lu Integer(sigio_intkind) input logical unit ! head Type(sigio_head) input header information ! data Type(sigio_data) input data fields ! iret Integer(sigio_intkind) output return code ! ! sigio_aldbta Allocate longreal data fields ! head Type(sigio_head) input header information ! dbta Type(sigio_dbta) output longreal data fields ! iret Integer(sigio_intkind) output return code ! ! sigio_axdbta Deallocate longreal data fields ! dbta Type(sigio_dbta) output longreal data fields ! iret Integer(sigio_intkind) output return code ! ! sigio_srdbta Read longreal data fields with sequential I/O ! lu Integer(sigio_intkind) input logical unit ! head Type(sigio_head) input header information ! dbta Type(sigio_dbta) output longreal data fields ! iret Integer(sigio_intkind) output return code ! ! sigio_swdbta Write longreal data fields with sequential I/O ! lu Integer(sigio_intkind) input logical unit ! head Type(sigio_head) input header information ! dbta Type(sigio_dbta) input longreal data fields ! iret Integer(sigio_intkind) output return code ! ! sigio_srohdc Open, read header & data and close with sequential I/O ! lu Integer(sigio_intkind) input logical unit ! cfname Character(*) input filename ! head Type(sigio_head) output header information ! data Type(sigio_data) or type(sigio_dbta) output data fields ! iret Integer(sigio_intkind) output return code ! ! sigio_swohdc Open, write header & data and close with sequential I/O ! lu Integer(sigio_intkind) input logical unit ! cfname Character(*) input filename ! head Type(sigio_head) input header information ! data Type(sigio_data) or type(sigio_dbta) output data fields ! iret Integer(sigio_intkind) output return code ! ! sigio_modpr Compute model pressures ! im Integer(sigio_intkind) input number of points ! ix Integer(sigio_intkind) input first dimension ! km Integer(sigio_intkind) input number of levels ! nvcoord Integer(sigio_intkind) input number of vertical coords ! idvc Integer(sigio_intkind) input vertical coordinate id ! (1 for sigma and 2 for hybrid) ! idsl Integer(sigio_intkind) input type of sigma structure ! (1 for phillips or 2 for mean) ! vcoord Real(sigio_realkind)(km+1,nvcoord) input vertical coords ! for idvc=1, nvcoord=1: sigma interface ! for idvc=2, nvcoord=2: hybrid interface a and b ! iret Integer(sigio_intkind) output return code ! ps Real(sigio_realkind)(ix) input optional surface pressure (Pa) ! tv Real(sigio_realkind)(ix,km) input optional virtual temperature (K) ! pd Real(sigio_realkind)(ix,km) output optional delta pressure (Pa) ! pm Real(sigio_realkind)(ix,km) output optional layer pressure (Pa) ! ! sigio_modprd Compute model pressures - double precision ! im Integer(sigio_intkind) input number of points ! ix Integer(sigio_intkind) input first dimension ! km Integer(sigio_intkind) input number of levels ! nvcoord Integer(sigio_intkind) input number of vertical coords ! idvc Integer(sigio_intkind) input vertical coordinate id ! (1 for sigma and 2 for hybrid) ! idsl Integer(sigio_intkind) input type of sigma structure ! (1 for phillips or 2 for mean) ! vcoord Real(sigio_realkind)(km+1,nvcoord) input vertical coords ! for idvc=1, nvcoord=1: sigma interface ! for idvc=2, nvcoord=2: hybrid interface a and b ! iret Integer(sigio_intkind) output return code ! ps Real(sigio_dblekind)(ix) input optional surface pressure (Pa) ! tv Real(sigio_dblekind)(ix,km) input optional virtual temperature (K) ! pd Real(sigio_dblekind)(ix,km) output optional delta pressure (Pa) ! pm Real(sigio_dblekind)(ix,km) output optional layer pressure (Pa) ! ! sigio_adhead Set private data in header ! head Type(sigio_head) input/output header information ! ! sigio_cnvpsv Convert from model mass variable to pressure (Pa) ! when cnflg > 0, or the opposite when cnflag <= 0. ! Values of IDVM determines variable. ! im Integer(sigio_intkind) input number of points ! idvm Integer(sigio_intkind) mass variable id ! ps Real(sigio_realkind)(im) inout mass variable or ps (Pa) ! dp Real(sigio_realkind)(im) output dp(out)/dp(in) ! cnflg Integer(sigio_intkind) input conversion flag. ! when >0, conversion is to surface pressure (Pa) and ! when <= 0, the conversion is to model mass variable. ! ! sigio_cnvtdv Convert from Virtual Temperature (Tv) or Enthalpy (h) ! to sensible Temperature (when cnflag > 0) and the opposite ! when cnflag <= 0. Values of IDVM determines Tv or h ! im Integer(sigio_intkind) input number of points ! ix Integer(sigio_intkind) input first dimension ! km Integer(sigio_intkind) input number of levels ! idvc Integer(sigio_intkind) input vertical coordinate id ! (1 for sigma, 2 for hybrid, and 3 for general hybrid) ! idvm Integer(sigio_intkind) mass variable id ! (32 for enthalpy) ! ntrac Integer(sigio_intkind) input number of tracers ! iret Integer(sigio_intkind) output return code ! t Real(sigio_realkind)(ix,km) input Tv, h or T ! q Real(sigio_realkind)(ix,km,ntrac) input tracers ! cpi Real(sigio_realkind)(ntrac) input specific heat at constant ! pressure for tracers ! cnflg Integer(sigio_intkind) input conversion flag. when >0 ! conversion is to dry temperature from Tv or h and when ! <= 0, the conversion is from dry temperature to Tv or h. ! ! Remarks: ! (1) The sigma file format follows: ! For ivs=198410: ! ON85 label (32 bytes) ! Header information record containing ! real forecast hour, initial date, sigma interfaces, sigma levels, ! padding to allow for 100 levels, and finally 44 identifier words ! containing JCAP, LEVS, NTRAC, IREALF, etc. (250 4-byte words) ! (word size in the remaining records depends on the value of IREALF) ! Orography (NC words, where NC=(JCAP+1)*(JCAP+2)) ! Log surface pressure (NC words) ! Temperature (LEVS records of NC words) ! Divergence & Vorticity interleaved (2*LEVS records of NC words) ! Tracers (LEVS*NTRAC records of NC words) ! Extra grid fields (NXGR records of LONB*LATB words) ! For ivs=200509: ! Label containing ! 'GFS ','SIG ',ivs,nhead,ndata,reserved(3) (8 4-byte words) ! Header records ! lhead(nhead),ldata(ndata) (nhead+ndata 4-byte words) ! fhour, idate(4), jcap, levs, itrun, iorder, irealf, igen, ! latf, lonf, latb, lonb, latr, lonr, ntrac, nvcoord, ! icen2, iens(2), idpp, idsl, idvc, idvm, idvt, idrun, idusr, ! pdryini, ncldt, ixgr, ixga,reserved(17) (50 4-byte words) ! vcoord((levs+1)*nvcoord 4-byte words) ! cfvars(5+ntrac 8-byte character words) ! Data records (word size depends on irealf) ! orography (nc words, where nc=(jcap+1)*(jcap+2)) ! log surface pressure (nc words) ! temperature (levs records of nc words) ! divergence (levs records of nc words) ! vorticity (levs records of nc words) ! tracers (levs*ntrac records of nc words) ! scalars (nxss words) ! extra physics grid fields (nxgr records of lonb*latb words) ! extra scalars (nxss words) ! extra dynamics grid fields (nxga records of lonf*latf words) ! ! (2) Possible return codes: ! 0 Successful call ! -1 Open or close I/O error ! -2 Header record I/O error (possible EOF) ! -3 Allocation or deallocation error ! -4 Data record I/O error ! -5 Insufficient data dimensions allocated ! ! Examples: ! (1) Read the entire sigma file 'sigf24' and ! print out the global mean temperature profile. ! ! use sigio_module ! type(sigio_head):: head ! type(sigio_data):: data ! call sigio_srohdc(11,'sigf24',head,data,iret) ! print '(f8.2)',data%t(1,head%levs:1:-1)/sqrt(2.) ! end ! ! Attributes: ! Language: Fortran 90 ! !$$$ implicit none private ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! Public Variables integer,parameter,public:: sigio_lhead1=32 integer,parameter,public:: sigio_intkind=4,sigio_realkind=4,sigio_dblekind=8 integer,parameter,public:: sigio_charkind=8 real(sigio_intkind),parameter,public:: sigio_intfill=-9999_sigio_intkind real(sigio_realkind),parameter,public:: sigio_realfill=-9999._sigio_realkind real(sigio_dblekind),parameter,public:: sigio_dblefill=-9999._sigio_dblekind ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! Public Types type,public:: sigio_head character(sigio_lhead1):: clabsig=' ' real(sigio_realkind):: fhour=sigio_realfill integer(sigio_intkind):: idate(4)=sigio_intfill real(sigio_realkind):: si(101)=sigio_realfill real(sigio_realkind):: sl(100)=sigio_realfill real(sigio_realkind):: ak(101)=sigio_realfill real(sigio_realkind):: bk(101)=sigio_realfill integer(sigio_intkind):: jcap=sigio_intfill integer(sigio_intkind):: levs=sigio_intfill integer(sigio_intkind):: itrun=sigio_intfill integer(sigio_intkind):: iorder=sigio_intfill integer(sigio_intkind):: irealf=sigio_intfill integer(sigio_intkind):: igen=sigio_intfill integer(sigio_intkind):: latf=sigio_intfill integer(sigio_intkind):: lonf=sigio_intfill integer(sigio_intkind):: latb=sigio_intfill integer(sigio_intkind):: lonb=sigio_intfill integer(sigio_intkind):: latr=sigio_intfill integer(sigio_intkind):: lonr=sigio_intfill integer(sigio_intkind):: ntrac=sigio_intfill integer(sigio_intkind):: icen2=sigio_intfill integer(sigio_intkind):: iens(2)=sigio_intfill integer(sigio_intkind):: idpp=sigio_intfill integer(sigio_intkind):: idsl=sigio_intfill integer(sigio_intkind):: idvc=sigio_intfill integer(sigio_intkind):: idvm=sigio_intfill integer(sigio_intkind):: idvt=sigio_intfill integer(sigio_intkind):: idrun=sigio_intfill integer(sigio_intkind):: idusr=sigio_intfill real(sigio_realkind):: pdryini=sigio_realfill integer(sigio_intkind):: ncldt=sigio_intfill integer(sigio_intkind):: ixgr=sigio_intfill integer(sigio_intkind):: ixga=sigio_intfill integer(sigio_intkind):: ivs=sigio_intfill integer(sigio_intkind):: nvcoord=sigio_intfill real(sigio_realkind),allocatable:: vcoord(:,:) character(sigio_charkind),allocatable:: cfvars(:) integer(sigio_intkind):: nxgr=sigio_intfill integer(sigio_intkind):: nxss=sigio_intfill integer(sigio_intkind):: nxga=sigio_intfill integer(sigio_intkind):: nhead=sigio_intfill integer(sigio_intkind):: ndata=sigio_intfill integer(sigio_intkind),allocatable:: lhead(:) integer(sigio_intkind),allocatable:: ldata(:) real(sigio_realkind), allocatable :: cpi(:), ri(:) ! real(sigio_realkind):: cpi(100)=sigio_realfill ! real(sigio_realkind):: ri(100)=sigio_realfill end type type,public:: sigio_data real(sigio_realkind),pointer:: hs(:)=>null() real(sigio_realkind),pointer:: ps(:)=>null() real(sigio_realkind),pointer:: t(:,:)=>null() real(sigio_realkind),pointer:: d(:,:)=>null() real(sigio_realkind),pointer:: z(:,:)=>null() real(sigio_realkind),pointer:: q(:,:,:)=>null() real(sigio_realkind),pointer:: xgr(:,:,:)=>null() real(sigio_realkind),pointer:: xss(:)=>null() real(sigio_realkind),pointer:: xga(:,:,:)=>null() end type type,public:: sigio_dbta real(sigio_dblekind),pointer:: hs(:)=>null() real(sigio_dblekind),pointer:: ps(:)=>null() real(sigio_dblekind),pointer:: t(:,:)=>null() real(sigio_dblekind),pointer:: d(:,:)=>null() real(sigio_dblekind),pointer:: z(:,:)=>null() real(sigio_dblekind),pointer:: q(:,:,:)=>null() real(sigio_dblekind),pointer:: xgr(:,:,:)=>null() real(sigio_dblekind),pointer:: xss(:)=>null() real(sigio_dblekind),pointer:: xga(:,:,:)=>null() end type ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! Public Subprograms public sigio_sropen,sigio_swopen,sigio_sclose,sigio_srhead,sigio_swhead public sigio_alhead,sigio_aldata,sigio_axdata,sigio_srdata,sigio_swdata public sigio_aldbta,sigio_axdbta,sigio_srdbta,sigio_swdbta public sigio_srohdc,sigio_swohdc ! public sigio_modpr,sigio_cnvtdv,sigio_cnvpsv public sigio_modpr,sigio_cnvtdv,sigio_cnvpsv public sigio_modprd,sigio_cnvtdvd,sigio_cnvpsvd interface sigio_srohdc module procedure sigio_srohdca,sigio_srohdcb end interface interface sigio_swohdc module procedure sigio_swohdca,sigio_swohdcb end interface ! interface sigio_modpr ! module procedure sigio_modprs, sigio_modprd ! end interface ! interface sigio_cnvtdv ! module procedure sigio_cnvtdvs, sigio_cnvtdvd ! end interface ! interface sigio_cnvps ! module procedure sigio_cnvpsvs, sigio_cnvpsvd ! end interface public sigio_adhead ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! Private Variables ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! Private Types type sigio_head2 sequence real(sigio_realkind):: fhour integer(sigio_intkind):: idate(4) real(sigio_realkind):: sisl(2*100+1) real(sigio_realkind):: ext(44) end type contains !------------------------------------------------------------------------------- subroutine sigio_sropen(lu,cfname,iret) implicit none integer(sigio_intkind),intent(in):: lu character*(*),intent(in):: cfname integer(sigio_intkind),intent(out):: iret integer ios ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - open(lu,file=cfname,form='unformatted',& status='old',action='read',iostat=ios) iret=ios if(iret.ne.0) iret=-1 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine !------------------------------------------------------------------------------- subroutine sigio_swopen(lu,cfname,iret) implicit none integer(sigio_intkind),intent(in):: lu character*(*),intent(in):: cfname integer(sigio_intkind),intent(out):: iret integer ios ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - open(lu,file=cfname,form='unformatted',& status='unknown',action='readwrite',iostat=ios) iret=ios if(iret.ne.0) iret=-1 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine !------------------------------------------------------------------------------- subroutine sigio_sclose(lu,iret) implicit none integer(sigio_intkind),intent(in):: lu integer(sigio_intkind),intent(out):: iret integer ios ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - close(lu,iostat=ios) iret=ios if(iret.ne.0) iret=-1 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine !------------------------------------------------------------------------------- subroutine sigio_srhead(lu,head,iret) implicit none integer(sigio_intkind),intent(in):: lu type(sigio_head),intent(inout):: head integer(sigio_intkind),intent(out):: iret type(sigio_head2):: head2 character(4):: cgfs,csig integer(sigio_intkind):: nhead,ndata,nresv(3) integer:: ios ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - iret=-2 rewind lu read(lu,iostat=ios) head%clabsig if(ios.ne.0) return if(head%clabsig(1:8).eq.'GFS SIG ') then ! modern sigma file rewind lu read(lu,iostat=ios) cgfs,csig,head%ivs,nhead,ndata,nresv if(ios.ne.0) return if(head%ivs.eq.200509) then read(lu,iostat=ios) if(ios.ne.0) return read(lu,iostat=ios) head%fhour,head%idate,head%jcap,head%levs,& head%itrun,head%iorder,head%irealf,head%igen,head%latf,head%lonf,& head%latb,head%lonb,head%latr,head%lonr,head%ntrac,head%nvcoord,& head%icen2,head%iens,head%idpp,head%idsl,head%idvc,head%idvm,& head%idvt,head%idrun,head%idusr,head%pdryini,head%ncldt,& head%ixgr, head%ixga if(ios.ne.0) return if(head%ixga==0) head%nxga=0 call sigio_alhead(head,iret) read(lu,iostat=ios) head%vcoord if(ios.ne.0) return read(lu,iostat=ios) head%cfvars if(ios.ne.0) return if (mod(head%idvm/10,10) == 3)then read(lu,iostat=ios) head%cpi if(ios.ne.0) return read(lu,iostat=ios) head%ri if(ios.ne.0) return endif head%clabsig=' ' head%si=sigio_realfill head%sl=sigio_realfill head%ak=sigio_realfill head%bk=sigio_realfill if(head%levs.lt.100.and.(head%idvc.eq.2.or.& (head%idvc.eq.3.and.all(head%vcoord(:,3).eq.0)))) then head%ak(1:head%levs+1)=head%vcoord(1:head%levs+1,1) head%bk(1:head%levs+1)=head%vcoord(1:head%levs+1,2) endif ! head%pdryini=sigio_realfill else return endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - else read(lu,iostat=ios) head2%fhour,head2%idate,head2%sisl,head2%ext if(ios.ne.0) return head%fhour=head2%fhour head%idate=head2%idate head%jcap=head2%ext(1) head%levs=head2%ext(2) head%itrun=head2%ext(3) head%iorder=head2%ext(4) head%irealf=head2%ext(5) head%igen=head2%ext(6) head%lonf=head2%ext(7) head%latf=head2%ext(8) head%lonb=head2%ext(9) head%latb=head2%ext(10) head%lonr=head2%ext(11) head%latr=head2%ext(12) head%ntrac=max(head2%ext(13),1.) head%icen2=head2%ext(14) head%iens=head2%ext(15:16) head%idpp=head2%ext(17) head%idsl=head2%ext(18) head%idvc=head2%ext(19) head%idvm=head2%ext(20) head%idvt=head2%ext(21) head%idrun=head2%ext(22) head%idusr=head2%ext(23) head%pdryini=head2%ext(24) head%ncldt=head2%ext(25) head%ixgr=head2%ext(26) head%ixga=head2%ext(27) head%si=sigio_realfill head%sl=sigio_realfill head%ak=sigio_realfill head%bk=sigio_realfill if(head%idvc.eq.0.or.head%idvc.eq.1) then head%si(1:head%levs+1)=head2%sisl(1:head%levs+1) head%sl(1:head%levs)=head2%sisl(head%levs+2:2*head%levs+1) head%nvcoord=1 call sigio_alhead(head,iret) head%vcoord(1:head%levs+1,1)=head2%sisl(1:head%levs+1) elseif(head%idvc.eq.2) then head%ak(1:head%levs+1)=head2%sisl(1:head%levs+1) head%bk(1:head%levs+1)=head2%sisl(head%levs+2:2*head%levs+2) head%nvcoord=2 call sigio_alhead(head,iret) head%vcoord(1:head%levs+1,1)=head2%sisl(1:head%levs+1) head%vcoord(1:head%levs+1,2)=head2%sisl(head%levs+2:2*head%levs+2) elseif(head%idvc.eq.3) then head%nvcoord=2 call sigio_alhead(head,iret) head%vcoord(1:head%levs+1,1)=head2%sisl(1:head%levs+1) head%vcoord(1:head%levs+1,2)=head2%sisl(head%levs+2:2*head%levs+2) endif head%ivs=198410 endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_adhead(head) iret=0 end subroutine !------------------------------------------------------------------------------- subroutine sigio_swhead(lu,head,iret) implicit none integer(sigio_intkind),intent(in):: lu type(sigio_head),intent(inout):: head integer(sigio_intkind),intent(out):: iret integer(sigio_intkind) lhead,ldata type(sigio_head2):: head2 integer:: ios integer i ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - iret=-2 call sigio_adhead(head) rewind lu if(head%ivs.ge.200509) then write(lu,iostat=ios) 'GFS SIG ',head%ivs,head%nhead,head%ndata,0,0,0 if(ios.ne.0) return write(lu,iostat=ios) head%lhead,head%ldata if(ios.ne.0) return write(lu,iostat=ios) head%fhour,head%idate,head%jcap,head%levs,& head%itrun,head%iorder,head%irealf,head%igen,head%latf,head%lonf,& head%latb,head%lonb,head%latr,head%lonr,head%ntrac,head%nvcoord,& head%icen2,head%iens,head%idpp,head%idsl,head%idvc,head%idvm,& head%idvt,head%idrun,head%idusr,head%pdryini,head%ncldt,& head%ixgr,head%ixga, (0,i=1,17) if(ios.ne.0) return if(size(head%vcoord).ne.(head%levs+1)*head%nvcoord) return write(lu,iostat=ios) head%vcoord if(ios.ne.0) return if(size(head%cfvars).ne.5+head%ntrac) return write(lu,iostat=ios) head%cfvars if(ios.ne.0) return if (mod(head%idvm/10,10) == 3) then write(lu,iostat=ios) head%cpi if(ios.ne.0) return write(lu,iostat=ios) head%ri if(ios.ne.0) return endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - else head2%fhour=head%fhour head2%idate=head%idate head2%sisl=0 if(head%idvc.eq.0.or.head%idvc.eq.1) then if(head%nvcoord.eq.1.and.head%vcoord(1,1).eq.1.) then head2%sisl(1:head%levs+1)=head%vcoord(1:head%levs+1,1) call sigio_modpr(1,1,head%levs,head%nvcoord,head%idvc,head%idsl,& head%vcoord,iret,ps=(/1./),& pm=head2%sisl(head%levs+2:2*head%levs+1)) else head2%sisl(1:head%levs+1)=head%si(1:head%levs+1) head2%sisl(head%levs+2:2*head%levs+1)=head%sl(1:head%levs) endif elseif(head%idvc.eq.2) then if(head%nvcoord.eq.2.and.head%vcoord(1,2).eq.1.) then head2%sisl(1:head%levs+1)=head%vcoord(1:head%levs+1,1) head2%sisl(head%levs+2:2*head%levs+2)=head%vcoord(1:head%levs+1,2) else head2%sisl(1:head%levs+1)=head%ak(1:head%levs+1) head2%sisl(head%levs+2:2*head%levs+2)=head%bk(1:head%levs+1) endif elseif(head%idvc.eq.3) then if(head%nvcoord.eq.2.and.head%vcoord(1,2).eq.1.) then head2%sisl(1:head%levs+1)=head%vcoord(1:head%levs+1,1) head2%sisl(head%levs+2:2*head%levs+2)=head%vcoord(1:head%levs+1,2) endif endif head2%ext(1)=head%jcap head2%ext(2)=head%levs head2%ext(3)=head%itrun head2%ext(4)=head%iorder head2%ext(5)=head%irealf head2%ext(6)=head%igen head2%ext(7)=head%lonf head2%ext(8)=head%latf head2%ext(9)=head%lonb head2%ext(10)=head%latb head2%ext(11)=head%lonr head2%ext(12)=head%latr head2%ext(13)=head%ntrac head2%ext(14)=head%icen2 head2%ext(15:16)=head%iens head2%ext(17)=head%idpp head2%ext(18)=head%idsl head2%ext(19)=head%idvc head2%ext(20)=head%idvm head2%ext(21)=head%idvt head2%ext(22)=head%idrun head2%ext(23)=head%idusr head2%ext(24)=head%pdryini head2%ext(25)=head%ncldt head2%ext(26)=head%ixgr head2%ext(27)=head%ixga head2%ext(28:44)=0 write(lu,iostat=ios) head%clabsig if(ios.ne.0) return write(lu,iostat=ios) head2%fhour,head2%idate,head2%sisl,head2%ext if(ios.ne.0) return endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - iret=0 end subroutine !------------------------------------------------------------------------------- subroutine sigio_alhead(head,iret,levs,nvcoord,ntrac,idvm) implicit none type(sigio_head),intent(inout):: head integer(sigio_intkind),intent(out):: iret integer(sigio_intkind),optional,intent(in):: levs,nvcoord,ntrac,idvm integer dim1v,dim2v,dim1c,thermodyn_id ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if(present(levs)) then dim1v=levs+1 else dim1v=head%levs+1 endif if(present(nvcoord)) then dim2v=nvcoord else dim2v=head%nvcoord endif if(present(ntrac)) then dim1c=5+ntrac else dim1c=5+head%ntrac endif if(allocated(head%vcoord)) deallocate(head%vcoord) if(allocated(head%cfvars)) deallocate(head%cfvars) allocate(head%vcoord(dim1v,dim2v),head%cfvars(dim1c),stat=iret) if(present(idvm)) then thermodyn_id=mod(idvm/10,10) else thermodyn_id=mod(head%idvm/10,10) endif if (thermodyn_id == 3) then if(allocated(head%cpi)) deallocate(head%cpi) if(allocated(head%ri)) deallocate(head%ri) allocate(head%cpi(dim1c-4),head%ri(dim1c-4),stat=iret) endif if(iret.eq.0) then head%vcoord=sigio_realfill head%cfvars=' ' endif if(iret.ne.0) iret=-3 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine !------------------------------------------------------------------------------- subroutine sigio_aldata(head,data,iret) implicit none type(sigio_head),intent(in):: head type(sigio_data),intent(inout):: data integer(sigio_intkind),intent(out):: iret integer nc,dim1,dim2,dim3q,dim1x,dim2x,dim3x ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_axdata(data,iret) nc=(head%jcap+1)*(head%jcap+2) dim1=nc dim2=head%levs dim3q=head%ntrac dim1x=head%lonb dim2x=head%latb dim3x=head%nxgr allocate(data%hs(dim1),data%ps(dim1),& data%t(dim1,dim2),data%d(dim1,dim2),data%z(dim1,dim2),& data%q(dim1,dim2,dim3q),& data%xgr(dim1x,dim2x,dim3x),data%xss(head%nxss),stat=iret) if(iret.ne.0) iret=-3 dim1x=head%lonf dim2x=head%latf dim3x=head%nxga allocate(data%xga(dim1x,dim2x,dim3x),stat=iret) if(iret.ne.0) iret=-3 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine !------------------------------------------------------------------------------- subroutine sigio_axdata(data,iret) implicit none type(sigio_data),intent(inout):: data integer(sigio_intkind),intent(out):: iret ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - deallocate(data%hs,data%ps,data%t,data%d,data%z,data%q,data%xgr,data%xga,stat=iret) nullify(data%hs,data%ps,data%t,data%d,data%z,data%q,data%xgr,data%xga) if(iret.ne.0) iret=-3 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine !------------------------------------------------------------------------------- subroutine sigio_srdata(lu,head,data,iret) implicit none integer(sigio_intkind),intent(in):: lu type(sigio_head),intent(in):: head type(sigio_data),intent(inout):: data integer(sigio_intkind),intent(out):: iret type(sigio_dbta):: dbta integer:: nc,mdim1,mdim2,mdim3q,mdim1x,mdim2x,mdim3x,k,n,ios ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - nc=(head%jcap+1)*(head%jcap+2) mdim1=min(size(data%hs,1),size(data%ps,1),& size(data%t,1),size(data%d,1),size(data%z,1),& size(data%q,1)) mdim2=min(size(data%t,2),size(data%d,2),size(data%z,2),& size(data%q,2)) mdim3q=size(data%q,3) iret=-5 if(mdim1.lt.nc.or.& mdim2.lt.head%levs.or.& mdim3q.lt.head%ntrac) return if(head%nxgr.gt.0) then mdim1x=size(data%xgr,1) mdim2x=size(data%xgr,2) mdim3x=size(data%xgr,3) if(mdim1x.lt.head%lonb.or.& mdim2x.lt.head%latb.or.& mdim3x.lt.head%nxgr) return if(size(data%xss).lt.head%nxss) return endif if(head%nxga.gt.0) then mdim1x=size(data%xga,1) mdim2x=size(data%xga,2) mdim3x=size(data%xga,3) if(mdim1x.lt.head%lonf.or.& mdim2x.lt.head%latf.or.& mdim3x.lt.head%nxga) return endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if(head%irealf.ne.2) then iret=-4 read(lu,iostat=ios) data%hs(:nc) if(ios.ne.0) return read(lu,iostat=ios) data%ps(:nc) if(ios.ne.0) return do k=1,head%levs read(lu,iostat=ios) data%t(:nc,k) if(ios.ne.0) return enddo do k=1,head%levs read(lu,iostat=ios) data%d(:nc,k) if(ios.ne.0) return read(lu,iostat=ios) data%z(:nc,k) if(ios.ne.0) return enddo do n=1,head%ntrac do k=1,head%levs read(lu,iostat=ios) data%q(:nc,k,n) if(ios.ne.0) return enddo enddo do n=1,head%nxgr read(lu,iostat=ios) data%xgr(:head%lonb,:head%latb,n) if(ios.ne.0) return enddo if(head%nxss.gt.0) then read(lu,iostat=ios) data%xss(:head%nxss) if(ios.ne.0) return endif if(head%nxga.gt.0) then do n=1,head%nxga read(lu,iostat=ios) data%xga(:head%lonf,:head%latf,n) if(ios.ne.0) return enddo endif iret=0 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - else call sigio_aldbta(head,dbta,iret) if(iret.ne.0) return call sigio_srdbta(lu,head,dbta,iret) if(iret.ne.0) return data%hs(:nc)=dbta%hs(:nc) data%ps(:nc)=dbta%ps(:nc) data%t(:nc,:head%levs)=dbta%t(:nc,:head%levs) data%d(:nc,:head%levs)=dbta%d(:nc,:head%levs) data%z(:nc,:head%levs)=dbta%z(:nc,:head%levs) data%q(:nc,:head%levs,:head%ntrac)=dbta%q(:nc,:head%levs,:head%ntrac) data%xgr(:head%lonb,:head%latb,:head%nxgr)=& dbta%xgr(:head%lonb,:head%latb,:head%nxgr) data%xss(:head%nxss)=dbta%xss(:head%nxss) data%xga(:head%lonf,:head%latf,:head%nxga)=& dbta%xga(:head%lonf,:head%latf,:head%nxga) call sigio_axdbta(dbta,iret) endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine !------------------------------------------------------------------------------- subroutine sigio_swdata(lu,head,data,iret) implicit none integer(sigio_intkind),intent(in):: lu type(sigio_head),intent(in):: head type(sigio_data),intent(in):: data integer(sigio_intkind),intent(out):: iret type(sigio_dbta):: dbta integer:: nc,mdim1,mdim2,mdim3q,mdim1x,mdim2x,mdim3x,k,n,ios ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - nc=(head%jcap+1)*(head%jcap+2) mdim1=min(size(data%hs,1),size(data%ps,1),& size(data%t,1),size(data%d,1),size(data%z,1),& size(data%q,1)) mdim2=min(size(data%t,2),size(data%d,2),size(data%z,2),& size(data%q,2)) mdim3q=size(data%q,3) iret=-5 if(mdim1.lt.nc.or.& mdim2.lt.head%levs.or.& mdim3q.lt.head%ntrac) return if(head%nxgr.gt.0) then mdim1x=size(data%xgr,1) mdim2x=size(data%xgr,2) mdim3x=size(data%xgr,3) if(mdim1x.lt.head%lonb.or.& mdim2x.lt.head%latb.or.& mdim3x.lt.head%nxgr) return if(size(data%xss).lt.head%nxss) return endif if(head%nxga.gt.0) then mdim1x=size(data%xga,1) mdim2x=size(data%xga,2) mdim3x=size(data%xga,3) if(mdim1x.lt.head%lonf.or.& mdim2x.lt.head%latf.or.& mdim3x.lt.head%nxga) return endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if(head%irealf.ne.2) then iret=-4 write(lu,iostat=ios) data%hs(:nc) if(ios.ne.0) return write(lu,iostat=ios) data%ps(:nc) if(ios.ne.0) return do k=1,head%levs write(lu,iostat=ios) data%t(:nc,k) if(ios.ne.0) return enddo do k=1,head%levs write(lu,iostat=ios) data%d(:nc,k) if(ios.ne.0) return write(lu,iostat=ios) data%z(:nc,k) if(ios.ne.0) return enddo do n=1,head%ntrac do k=1,head%levs write(lu,iostat=ios) data%q(:nc,k,n) if(ios.ne.0) return enddo enddo do n=1,head%nxgr write(lu,iostat=ios) data%xgr(:head%lonb,:head%latb,n) if(ios.ne.0) return enddo if(head%nxss.gt.0) then write(lu,iostat=ios) data%xss(:head%nxss) if(ios.ne.0) return endif if(head%nxga.gt.0) then do n=1,head%nxga write(lu,iostat=ios) data%xga(:head%lonf,:head%latf,n) if(ios.ne.0) return enddo endif iret=0 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - else call sigio_aldbta(head,dbta,iret) if(iret.ne.0) return dbta%hs(:nc)=data%hs(:nc) dbta%ps(:nc)=data%ps(:nc) dbta%t(:nc,:head%levs)=data%t(:nc,:head%levs) dbta%d(:nc,:head%levs)=data%d(:nc,:head%levs) dbta%z(:nc,:head%levs)=data%z(:nc,:head%levs) dbta%q(:nc,:head%levs,:head%ntrac)=data%q(:nc,:head%levs,:head%ntrac) dbta%xgr(:head%lonb,:head%latb,:head%nxgr)=& data%xgr(:head%lonb,:head%latb,:head%nxgr) dbta%xss(:head%nxss)=data%xss(:head%nxss) dbta%xga(:head%lonf,:head%latf,:head%nxga)=& data%xga(:head%lonf,:head%latf,:head%nxga) call sigio_swdbta(lu,head,dbta,iret) if(iret.ne.0) return call sigio_axdbta(dbta,iret) endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine !------------------------------------------------------------------------------- subroutine sigio_srohdca(lu,cfname,head,data,iret) implicit none integer(sigio_intkind),intent(in):: lu character*(*),intent(in):: cfname type(sigio_head),intent(inout):: head type(sigio_data),intent(inout):: data integer(sigio_intkind),intent(out):: iret ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_sropen(lu,cfname,iret) if(iret.ne.0) return ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_srhead(lu,head,iret) if(iret.ne.0) return ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_aldata(head,data,iret) if(iret.ne.0) return ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_srdata(lu,head,data,iret) if(iret.ne.0) return ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_sclose(lu,iret) if(iret.ne.0) return ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine !------------------------------------------------------------------------------- subroutine sigio_swohdca(lu,cfname,head,data,iret) implicit none integer(sigio_intkind),intent(in):: lu character*(*),intent(in):: cfname type(sigio_head),intent(inout):: head type(sigio_data),intent(in):: data integer(sigio_intkind),intent(out):: iret ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_swopen(lu,cfname,iret) if(iret.ne.0) return ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_swhead(lu,head,iret) if(iret.ne.0) return ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_swdata(lu,head,data,iret) if(iret.ne.0) return ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_sclose(lu,iret) if(iret.ne.0) return ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine !------------------------------------------------------------------------------- subroutine sigio_aldbta(head,dbta,iret) implicit none type(sigio_head),intent(in):: head type(sigio_dbta),intent(inout):: dbta integer(sigio_intkind),intent(out):: iret integer nc,dim1,dim2,dim3q,dim1x,dim2x,dim3x ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_axdbta(dbta,iret) nc=(head%jcap+1)*(head%jcap+2) dim1=nc dim2=head%levs dim3q=head%ntrac dim1x=head%lonb dim2x=head%latb dim3x=head%nxgr allocate(dbta%hs(dim1),dbta%ps(dim1),& dbta%t(dim1,dim2),dbta%d(dim1,dim2),dbta%z(dim1,dim2),& dbta%q(dim1,dim2,dim3q),& dbta%xgr(dim1x,dim2x,dim3x),dbta%xss(head%nxss),stat=iret) if(iret.ne.0) iret=-3 dim1x=head%lonf dim2x=head%latf dim3x=head%nxga allocate(dbta%xga(dim1x,dim2x,dim3x),stat=iret) if(iret.ne.0) iret=-4 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine !------------------------------------------------------------------------------- subroutine sigio_axdbta(dbta,iret) implicit none type(sigio_dbta),intent(inout):: dbta integer(sigio_intkind),intent(out):: iret ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - deallocate(dbta%hs,dbta%ps,dbta%t,dbta%d,dbta%z,dbta%q,dbta%xgr,dbta%xga,stat=iret) nullify(dbta%hs,dbta%ps,dbta%t,dbta%d,dbta%z,dbta%q,dbta%xgr,dbta%xga) if(iret.ne.0) iret=-3 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine !------------------------------------------------------------------------------- subroutine sigio_srdbta(lu,head,dbta,iret) implicit none integer(sigio_intkind),intent(in):: lu type(sigio_head),intent(in):: head type(sigio_dbta),intent(inout):: dbta integer(sigio_intkind),intent(out):: iret type(sigio_data):: data integer:: nc,mdim1,mdim2,mdim3q,mdim1x,mdim2x,mdim3x,k,n,ios ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - nc=(head%jcap+1)*(head%jcap+2) mdim1=min(size(dbta%hs,1),size(dbta%ps,1),& size(dbta%t,1),size(dbta%d,1),size(dbta%z,1),& size(dbta%q,1)) mdim2=min(size(dbta%t,2),size(dbta%d,2),size(dbta%z,2),& size(dbta%q,2)) mdim3q=size(dbta%q,3) iret=-5 if(mdim1.lt.nc.or.& mdim2.lt.head%levs.or.& mdim3q.lt.head%ntrac) return if(head%nxgr.gt.0) then mdim1x=size(dbta%xgr,1) mdim2x=size(dbta%xgr,2) mdim3x=size(dbta%xgr,3) if(mdim1x.lt.head%lonb.or.& mdim2x.lt.head%latb.or.& mdim3x.lt.head%nxgr) return if(size(dbta%xss).lt.head%nxss) return endif if(head%nxga.gt.0) then mdim1x=size(dbta%xga,1) mdim2x=size(dbta%xga,2) mdim3x=size(dbta%xga,3) if(mdim1x.lt.head%lonf.or.& mdim2x.lt.head%latf.or.& mdim3x.lt.head%nxga) return endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if(head%irealf.ne.2) then call sigio_aldata(head,data,iret) if(iret.ne.0) return call sigio_srdata(lu,head,data,iret) if(iret.ne.0) return dbta%hs(:nc)=data%hs(:nc) dbta%ps(:nc)=data%ps(:nc) dbta%t(:nc,:head%levs)=data%t(:nc,:head%levs) dbta%d(:nc,:head%levs)=data%d(:nc,:head%levs) dbta%z(:nc,:head%levs)=data%z(:nc,:head%levs) dbta%q(:nc,:head%levs,:head%ntrac)=data%q(:nc,:head%levs,:head%ntrac) dbta%xgr(:head%lonb,:head%latb,:head%nxgr)=& data%xgr(:head%lonb,:head%latb,:head%nxgr) dbta%xss(:head%nxss)=data%xss(:head%nxss) dbta%xga(:head%lonf,:head%latf,:head%nxga)=& data%xga(:head%lonf,:head%latf,:head%nxga) call sigio_axdata(data,iret) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - else iret=-4 read(lu,iostat=ios) dbta%hs(:nc) if(ios.ne.0) return read(lu,iostat=ios) dbta%ps(:nc) if(ios.ne.0) return do k=1,head%levs read(lu,iostat=ios) dbta%t(:nc,k) if(ios.ne.0) return enddo do k=1,head%levs read(lu,iostat=ios) dbta%d(:nc,k) if(ios.ne.0) return read(lu,iostat=ios) dbta%z(:nc,k) if(ios.ne.0) return enddo do n=1,head%ntrac do k=1,head%levs read(lu,iostat=ios) dbta%q(:nc,k,n) if(ios.ne.0) return enddo enddo do n=1,head%nxgr read(lu,iostat=ios) dbta%xgr(:head%lonb,:head%latb,n) if(ios.ne.0) return enddo if(head%nxss.gt.0) then read(lu,iostat=ios) dbta%xss(:head%nxss) if(ios.ne.0) return endif if(head%nxga.gt.0) then do n=1,head%nxga read(lu,iostat=ios) dbta%xga(:head%lonf,:head%latf,n) if(ios.ne.0) return enddo endif iret=0 endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine !------------------------------------------------------------------------------- subroutine sigio_swdbta(lu,head,dbta,iret) implicit none integer(sigio_intkind),intent(in):: lu type(sigio_head),intent(in):: head type(sigio_dbta),intent(in):: dbta integer(sigio_intkind),intent(out):: iret type(sigio_data):: data integer:: nc,mdim1,mdim2,mdim3q,mdim1x,mdim2x,mdim3x,k,n,ios ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - nc=(head%jcap+1)*(head%jcap+2) mdim1=min(size(dbta%hs,1),size(dbta%ps,1),& size(dbta%t,1),size(dbta%d,1),size(dbta%z,1),& size(dbta%q,1)) mdim2=min(size(dbta%t,2),size(dbta%d,2),size(dbta%z,2),& size(dbta%q,2)) mdim3q=size(dbta%q,3) iret=-5 if(mdim1.lt.nc.or.& mdim2.lt.head%levs.or.& mdim3q.lt.head%ntrac) return if(head%nxgr.gt.0) then mdim1x=size(dbta%xgr,1) mdim2x=size(dbta%xgr,2) mdim3x=size(dbta%xgr,3) if(mdim1x.lt.head%lonb.or.& mdim2x.lt.head%latb.or.& mdim3x.lt.head%nxgr) return if(size(dbta%xss).lt.head%nxss) return endif if(head%nxga.gt.0) then mdim1x=size(dbta%xga,1) mdim2x=size(dbta%xga,2) mdim3x=size(dbta%xga,3) if(mdim1x.lt.head%lonf.or.& mdim2x.lt.head%latf.or.& mdim3x.lt.head%nxga) return endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if(head%irealf.ne.2) then call sigio_aldata(head,data,iret) if(iret.ne.0) return data%hs(:nc)=dbta%hs(:nc) data%ps(:nc)=dbta%ps(:nc) data%t(:nc,:head%levs)=dbta%t(:nc,:head%levs) data%d(:nc,:head%levs)=dbta%d(:nc,:head%levs) data%z(:nc,:head%levs)=dbta%z(:nc,:head%levs) data%q(:nc,:head%levs,:head%ntrac)=dbta%q(:nc,:head%levs,:head%ntrac) data%xgr(:head%lonb,:head%latb,:head%nxgr)=& dbta%xgr(:head%lonb,:head%latb,:head%nxgr) data%xss(:head%nxss)=dbta%xss(:head%nxss) data%xga(:head%lonf,:head%latf,:head%nxga)=& dbta%xga(:head%lonf,:head%latf,:head%nxga) call sigio_swdata(lu,head,data,iret) if(iret.ne.0) return call sigio_axdata(data,iret) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - else iret=-4 write(lu,iostat=ios) dbta%hs(:nc) if(ios.ne.0) return write(lu,iostat=ios) dbta%ps(:nc) if(ios.ne.0) return do k=1,head%levs write(lu,iostat=ios) dbta%t(:nc,k) if(ios.ne.0) return enddo do k=1,head%levs write(lu,iostat=ios) dbta%d(:nc,k) if(ios.ne.0) return write(lu,iostat=ios) dbta%z(:nc,k) if(ios.ne.0) return enddo do n=1,head%ntrac do k=1,head%levs write(lu,iostat=ios) dbta%q(:nc,k,n) if(ios.ne.0) return enddo enddo do n=1,head%nxgr write(lu,iostat=ios) dbta%xgr(:head%lonb,:head%latb,n) if(ios.ne.0) return enddo if(head%nxss.gt.0) then write(lu,iostat=ios) dbta%xss(:head%nxss) if(ios.ne.0) return endif if(head%nxga.gt.0) then do n=1,head%nxga write(lu,iostat=ios) dbta%xga(:head%lonf,:head%latf,n) if(ios.ne.0) return enddo endif iret=0 endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine !------------------------------------------------------------------------------- subroutine sigio_srohdcb(lu,cfname,head,dbta,iret) implicit none integer(sigio_intkind),intent(in):: lu character*(*),intent(in):: cfname type(sigio_head),intent(inout):: head type(sigio_dbta),intent(inout):: dbta integer(sigio_intkind),intent(out):: iret ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_sropen(lu,cfname,iret) if(iret.ne.0) return ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_srhead(lu,head,iret) if(iret.ne.0) return ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_aldbta(head,dbta,iret) if(iret.ne.0) return ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_srdbta(lu,head,dbta,iret) if(iret.ne.0) return ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_sclose(lu,iret) if(iret.ne.0) return ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine !------------------------------------------------------------------------------- subroutine sigio_swohdcb(lu,cfname,head,dbta,iret) implicit none integer(sigio_intkind),intent(in):: lu character*(*),intent(in):: cfname type(sigio_head),intent(inout):: head type(sigio_dbta),intent(in):: dbta integer(sigio_intkind),intent(out):: iret ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_swopen(lu,cfname,iret) if(iret.ne.0) return ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_swhead(lu,head,iret) if(iret.ne.0) return ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_swdbta(lu,head,dbta,iret) if(iret.ne.0) return ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_sclose(lu,iret) if(iret.ne.0) return ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine !------------------------------------------------------------------------------- subroutine sigio_modpr(im,ix,km,nvcoord,idvc,idsl,vcoord,iret,& ps,t,pd,dpddps,dpddt,pm,dpmdps,dpmdt) implicit none integer,intent(in):: im,ix,km,nvcoord,idvc,idsl real,intent(in):: vcoord(km+1,nvcoord) integer,intent(out):: iret real,intent(in),optional:: ps(ix),t(ix,km) real,intent(out),optional:: pd(ix,km),pm(ix,km) real,intent(out),optional:: dpddps(ix,km),dpddt(ix,km) real,intent(out),optional:: dpmdps(ix,km),dpmdt(ix,km) real(sigio_dblekind),parameter:: rocp=287.05/1004.6,rocpr=1/rocp real(sigio_dblekind),parameter:: t00=300. integer id1,id2 real(sigio_dblekind) pid(im),dpiddps(im),dpiddt(im),tid(im),pidk(im) real(sigio_dblekind) piu,dpiudps,dpiudt,tiu,piuk real(sigio_dblekind) pmm,dpmdpid,dpmdpiu real(sigio_dblekind) pmk integer i,k ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if((idvc.eq.0.or.idvc.eq.1).and.nvcoord.eq.1.and.present(ps)) then id1=11 elseif(idvc.eq.2.and.nvcoord.eq.2.and.present(ps)) then id1=22 elseif(idvc.eq.3.and.nvcoord.eq.3.and.all(vcoord(:,3).eq.0).and.present(ps)) then id1=22 elseif(idvc.eq.3.and.nvcoord.eq.2.and.present(ps).and.present(t)) then id1=32 elseif(idvc.eq.3.and.nvcoord.eq.3.and.present(ps).and.present(t)) then id1=33 else id1=0 endif if(idsl.eq.0.or.idsl.eq.1) then id2=1 elseif(idsl.eq.2) then id2=2 else id2=0 endif iret=0 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if(id1.gt.0.and.id2.gt.0) then !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i) do i=1,im pid(i)=ps(i) dpiddps(i)=1 dpiddt(i)=0 tid(i)=0 if(id2.eq.1) pidk(i)=pid(i)**rocp enddo !$OMP END PARALLEL DO !!$OMP PARALLEL DO DEFAULT(SHARED) & !!$OMP& PRIVATE(i,k,piu,dpiudps,dpiudt,tiu,piuk,pmk,pmm,dpmdpid,dpmdpiu) & !!$OMP& PRIVATE(pid,dpiddps,dpiddt,tid,pidk) do k=1,km !$OMP PARALLEL DO DEFAULT(SHARED) & !$OMP& PRIVATE(i,piu,dpiudps,dpiudt,tiu,piuk,pmk,pmm,dpmdpid,dpmdpiu) do i=1,im select case(id1) case(11) piu=vcoord(k+1,1)*ps(i) dpiudps=vcoord(k+1,1) dpiudt=0 case(22) piu=vcoord(k+1,1)+vcoord(k+1,2)*ps(i) dpiudps=vcoord(k+1,2) dpiudt=0 case(32) tiu=(t(i,k)+t(i,min(k+1,km)))/2 piu=vcoord(k+1,2)*ps(i)+vcoord(k+1,1)*(tiu/t00)**rocpr dpiudps=vcoord(k+1,2) dpiudt=vcoord(k+1,1)*(tiu/t00)**rocpr*rocpr/tiu if(k.lt.km) dpiudt=dpiudt/2 case(33) tiu=(t(i,k)+t(i,min(k+1,km)))/2 piu=vcoord(k+1,1)+vcoord(k+1,2)*ps(i)+vcoord(k+1,3)*(tiu/t00)**rocpr dpiudps=vcoord(k+1,2) dpiudt=vcoord(k+1,3)*(tiu/t00)**rocpr*rocpr/tiu if(k.lt.km) dpiudt=dpiudt/2 end select if(present(pd)) pd(i,k)=pid(i)-piu if(present(dpddps)) dpddps(i,k)=dpiddps(i)-dpiudps if(present(dpddt)) dpddt(i,k)=dpiddt(i)-dpiudt ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - select case(id2) case(1) piuk=piu**rocp pmk=(pid(i)*pidk(i)-piu*piuk)/((rocp+1)*(pid(i)-piu)) pmm=pmk**rocpr dpmdpid=rocpr*pmm/(pid(i)-piu)*(pidk(i)/pmk-1) dpmdpiu=rocpr*pmm/(pid(i)-piu)*(1-piuk/pmk) case(2) pmm=(pid(i)+piu)/2 dpmdpid=0.5 dpmdpiu=0.5 end select if(present(pm)) pm(i,k)=pmm if(present(dpmdps)) dpmdps(i,k)=dpmdpid*dpiddps(i)+dpmdpiu*dpiudps if(present(dpmdt)) dpmdt(i,k)=dpmdpid*dpiddt(i)+dpmdpiu*dpiudt ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - pid(i)=piu dpiddps(i)=dpiudps dpiddt(i)=dpiudt tid(i)=tiu if(id2.eq.1) pidk(i)=piuk enddo !$OMP END PARALLEL DO enddo !!$OMP END PARALLEL DO else if(id1.le.0) iret=iret+1 if(id2.le.0) iret=iret+2 endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine !------------------------------------------------------------------------------- subroutine sigio_modprd(im,ix,km,nvcoord,idvc,idsl,vcoord,iret,& ps,t,pd,dpddps,dpddt,pm,dpmdps,dpmdt) implicit none integer,intent(in):: im,ix,km,nvcoord,idvc,idsl real(sigio_dblekind),intent(in):: vcoord(km+1,nvcoord) integer,intent(out):: iret real(sigio_dblekind),intent(in),optional:: ps(ix),t(ix,km) real(sigio_dblekind),intent(out),optional:: pd(ix,km),pm(ix,km) real(sigio_dblekind),intent(out),optional:: dpddps(ix,km),dpddt(ix,km) real(sigio_dblekind),intent(out),optional:: dpmdps(ix,km),dpmdt(ix,km) real(sigio_dblekind),parameter:: rocp=287.05/1004.6,rocpr=1/rocp real(sigio_dblekind),parameter:: t00=300. integer id1,id2 real(sigio_dblekind) pid(im),dpiddps(im),dpiddt(im),tid(im),pidk(im) real(sigio_dblekind) piu,dpiudps,dpiudt,tiu,piuk real(sigio_dblekind) pmm,dpmdpid,dpmdpiu real(sigio_dblekind) pmk integer i,k ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if((idvc.eq.0.or.idvc.eq.1).and.nvcoord.eq.1.and.present(ps)) then id1=11 elseif(idvc.eq.2.and.nvcoord.eq.2.and.present(ps)) then id1=22 elseif(idvc.eq.3.and.nvcoord.eq.3.and.all(vcoord(:,3).eq.0).and.present(ps)) then id1=22 elseif(idvc.eq.3.and.nvcoord.eq.2.and.present(ps).and.present(t)) then id1=32 elseif(idvc.eq.3.and.nvcoord.eq.3.and.present(ps).and.present(t)) then id1=33 else id1=0 endif if(idsl.eq.0.or.idsl.eq.1) then id2=1 elseif(idsl.eq.2) then id2=2 else id2=0 endif iret=0 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if(id1.gt.0.and.id2.gt.0) then !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i) do i=1,im pid(i)=ps(i) dpiddps(i)=1 dpiddt(i)=0 tid(i)=0 if(id2.eq.1) pidk(i)=pid(i)**rocp enddo !$OMP END PARALLEL DO !!$OMP PARALLEL DO DEFAULT(SHARED) & !!$OMP& PRIVATE(i,k,piu,dpiudps,dpiudt,tiu,piuk,pmk,pmm,dpmdpid,dpmdpiu) & !!$OMP& PRIVATE(pid,dpiddps,dpiddt,tid,pidk) do k=1,km !$OMP PARALLEL DO DEFAULT(SHARED) & !$OMP& PRIVATE(i,piu,dpiudps,dpiudt,tiu,piuk,pmk,pmm,dpmdpid,dpmdpiu) do i=1,im select case(id1) case(11) piu=vcoord(k+1,1)*ps(i) dpiudps=vcoord(k+1,1) dpiudt=0 case(22) piu=vcoord(k+1,1)+vcoord(k+1,2)*ps(i) dpiudps=vcoord(k+1,2) dpiudt=0 case(32) tiu=(t(i,k)+t(i,min(k+1,km)))/2 piu=vcoord(k+1,2)*ps(i)+vcoord(k+1,1)*(tiu/t00)**rocpr dpiudps=vcoord(k+1,2) dpiudt=vcoord(k+1,1)*(tiu/t00)**rocpr*rocpr/tiu if(k.lt.km) dpiudt=dpiudt/2 case(33) tiu=(t(i,k)+t(i,min(k+1,km)))/2 piu=vcoord(k+1,1)+vcoord(k+1,2)*ps(i)+vcoord(k+1,3)*(tiu/t00)**rocpr dpiudps=vcoord(k+1,2) dpiudt=vcoord(k+1,3)*(tiu/t00)**rocpr*rocpr/tiu if(k.lt.km) dpiudt=dpiudt/2 end select if(present(pd)) pd(i,k)=pid(i)-piu if(present(dpddps)) dpddps(i,k)=dpiddps(i)-dpiudps if(present(dpddt)) dpddt(i,k)=dpiddt(i)-dpiudt ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - select case(id2) case(1) piuk=piu**rocp pmk=(pid(i)*pidk(i)-piu*piuk)/((rocp+1)*(pid(i)-piu)) pmm=pmk**rocpr dpmdpid=rocpr*pmm/(pid(i)-piu)*(pidk(i)/pmk-1) dpmdpiu=rocpr*pmm/(pid(i)-piu)*(1-piuk/pmk) case(2) pmm=(pid(i)+piu)/2 dpmdpid=0.5 dpmdpiu=0.5 end select if(present(pm)) pm(i,k)=pmm if(present(dpmdps)) dpmdps(i,k)=dpmdpid*dpiddps(i)+dpmdpiu*dpiudps if(present(dpmdt)) dpmdt(i,k)=dpmdpid*dpiddt(i)+dpmdpiu*dpiudt ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - pid(i)=piu dpiddps(i)=dpiudps dpiddt(i)=dpiudt tid(i)=tiu if(id2.eq.1) pidk(i)=piuk enddo !$OMP END PARALLEL DO enddo !!$OMP END PARALLEL DO else if(id1.le.0) iret=iret+1 if(id2.le.0) iret=iret+2 endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine !------------------------------------------------------------------------------- subroutine sigio_adhead(head) implicit none type(sigio_head),intent(inout):: head integer jxss,nspec,n1,n2 integer a, b, c integer n3dzhaocld, n3dfercld, n3dcldpdf, n3dflxtvd integer n2dzhaocld, n2dfercld, n2dcldpdf, n2dflxtvd integer num_p3d, num_p2d, num_a3d, num_a2d !--for physics head%nxgr=0 head%nxss=0 n3dzhaocld=0; n3dfercld=0; n3dcldpdf=0 n2dzhaocld=0; n2dfercld=0; n2dcldpdf=0 a=mod(head%ixgr,10) b=int(mod(head%ixgr,100)/10) c=int(mod(head%ixgr,1000)/100) if (a.eq.1) then n2dzhaocld=0 n3dzhaocld=2 head%nxss=0 else if (a.eq.2) then n2dzhaocld=2 n3dzhaocld=4 head%nxss=0 else if (a.eq.3) then n2dzhaocld=2 n3dzhaocld=4 head%nxss=1 endif if (b.eq.1) then n2dfercld=0 n3dfercld=3 head%nxss=0 else if (b.eq.2) then n2dfercld=0 n3dfercld=3 head%nxss=1 endif if (c.eq.1) then n2dcldpdf=0 n3dcldpdf=3 endif num_p3d=n3dzhaocld+n3dfercld+n3dcldpdf !! num_p2d=1 is reserved for "ddvel", sfc wind enhancement due to convection num_p2d=1+n2dzhaocld+n2dfercld+n2dcldpdf if(head%ixgr<=0) num_p2d=0 head%nxgr=num_p3d*head%levs+num_p2d !--for dynamics head%nxga=0 n3dflxtvd=0 n2dflxtvd=0 a=mod(head%ixga,10) if (a.eq.1) then n2dflxtvd=0 n3dflxtvd=head%ntrac endif num_a3d=n3dflxtvd num_a2d=n2dflxtvd head%nxga=num_a3d*head%levs+num_a2d nspec=2+(3+head%ntrac)*head%levs if(head%ivs.eq.200509) then jxss=0 if(head%nxss.gt.0) jxss=1 head%nhead=5 if (mod(head%idvm/10,10) == 3) then head%nhead=7 endif head%ndata=nspec+head%nxgr+jxss+head%nxga if(allocated(head%lhead)) deallocate(head%lhead) if(allocated(head%ldata)) deallocate(head%ldata) allocate(head%lhead(head%nhead)) allocate(head%ldata(head%ndata)) if (mod(head%idvm/10,10) .ne. 3) then head%lhead=(/sigio_lhead1,4*(head%nhead+head%ndata),4*50,& 4*((head%levs+1)*head%nvcoord),8*(5+head%ntrac)/) ! if (mod(head%idvm/10,10) == 3) then else head%lhead=(/sigio_lhead1,4*(head%nhead+head%ndata),4*50, & 4*((head%levs+1)*head%nvcoord),8*(5+head%ntrac), & 4*(head%ntrac+1), 4*(head%ntrac+1)/) ! 400, 400/) endif head%ldata(1:nspec)=4*head%irealf*(head%jcap+1)*(head%jcap+2) n1=nspec+1; n2=nspec+head%nxgr if(head%nxgr>0) head%ldata(n1:n2)=4*head%irealf*head%lonb*head%latb n1=nspec+head%nxgr+1; n2=nspec+head%nxgr+jxss if(jxss>0) head%ldata(n1:n2)=4*head%irealf*head%nxss n1=nspec+head%nxgr+jxss+1; n2=nspec+head%nxgr+jxss+head%nxga if(head%nxga>0) head%ldata(n1:n2)=4*head%irealf*head%lonf*head%latf else head%nhead=2 head%ndata=nspec+head%nxgr+head%nxga if(allocated(head%lhead)) deallocate(head%lhead) if(allocated(head%ldata)) deallocate(head%ldata) allocate(head%lhead(head%nhead)) allocate(head%ldata(head%ndata)) head%lhead=(/sigio_lhead1,4*250/) head%ldata(1:nspec)=4*head%irealf*(head%jcap+1)*(head%jcap+2) head%ldata(nspec+1:nspec+head%nxgr)=4*head%irealf*head%lonb*head%latb head%ldata(nspec+head%nxgr+1:head%ndata)=4*head%irealf*head%lonf*head%latf endif end subroutine !------------------------------------------------------------------------------- subroutine sigio_cnvpsv(im,idvm,ps,dp,cnflg) implicit none integer,intent(in) :: im,idvm,cnflg real,intent(inout) :: ps(im) real,intent(out) :: dp(im) integer :: surfpress_id ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - surfpress_id = mod(idvm,10) if (cnflg > 0) then if (surfpress_id == 2) then dp=1.e3 ps=ps*1.e3 else dp=exp(ps)*1.e3 ps=exp(ps)*1.e3 endif else if (surfpress_id == 2) then dp=1/1.e3 ps=ps/1.e3 else dp=1/ps ps=log(ps/1.e3) endif endif end subroutine sigio_cnvpsv !------------------------------------------------------------------------------- subroutine sigio_cnvtdv(im,ix,km,idvc,idvm,ntrac,iret,t,q,cpi,cnflg) implicit none integer,intent(in):: im,ix,km,idvc,idvm,ntrac,cnflg integer,intent(out):: iret real,intent(in) :: q(ix,km,ntrac), cpi(0:ntrac) real,intent(inout) :: t(ix,km) integer :: thermodyn_id, n real :: xcp(ix,km), sumq(ix,km) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - thermodyn_id = mod(IDVM/10,10) ! if (thermodyn_id == 3 .and. idvc == 3) then xcp(1:im,:) = 0.0 sumq(1:im,:) = 0.0 do n=1,NTRAC if( cpi(n) .ne. 0.0) 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,:) = (1.-sumq(1:im,:))*cpi(0) + xcp(1:im,:) ! Mean Cp ! else xcp(1:im,:) = (1.+(461.50/287.05-1)*Q(1:im,:,1)) ! Virt factor endif if (cnflg > 0) then t(1:im,:) = t(1:im,:) / xcp(1:im,:) else t(1:im,:) = t(1:im,:) * xcp(1:im,:) endif iret = 0 ! return ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine sigio_cnvtdv !------------------------------------------------------------------------------- subroutine sigio_cnvpsvd(im,idvm,ps,dp,cnflg) implicit none integer,intent(in) :: im,idvm,cnflg real(sigio_dblekind),intent(inout) :: ps(im) real(sigio_dblekind),intent(out) :: dp(im) integer :: surfpress_id ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - surfpress_id = mod(idvm,10) if (cnflg > 0) then if (surfpress_id == 2) then dp=1.e3 ps=ps*1.e3 else dp=exp(ps)*1.e3 ps=exp(ps)*1.e3 endif else if (surfpress_id == 2) then dp=1/1.e3 ps=ps/1.e3 else dp=1/ps ps=log(ps/1.e3) endif endif end subroutine sigio_cnvpsvd !------------------------------------------------------------------------------- subroutine sigio_cnvtdvd(im,ix,km,idvc,idvm,ntrac,iret,t,q,cpi,cnflg) implicit none integer,intent(in):: im,ix,km,idvc,idvm,ntrac,cnflg integer,intent(out):: iret real(sigio_realkind),intent(in) :: cpi(0:ntrac) real(sigio_dblekind),intent(in) :: q(ix,km,ntrac) ! real(sigio_dblekind),intent(in) :: q(ix,km,ntrac), cpi(0:ntrac) real(sigio_dblekind),intent(inout) :: t(ix,km) integer :: thermodyn_id, n real(sigio_dblekind) :: xcp(ix,km), sumq(ix,km) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - thermodyn_id = mod(IDVM/10,10) ! if (thermodyn_id == 3 .and. idvc == 3) then xcp(1:im,:) = 0.0 sumq(1:im,:) = 0.0 do n=1,NTRAC if( cpi(n) .ne. 0.0) 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,:) = (1.-sumq(1:im,:))*cpi(0) + xcp(1:im,:) ! Mean Cp ! else xcp(1:im,:) = (1.+(461.50/287.05-1)*Q(1:im,:,1)) ! Virt factor endif if (cnflg > 0) then t(1:im,:) = t(1:im,:) / xcp(1:im,:) else t(1:im,:) = t(1:im,:) * xcp(1:im,:) endif iret = 0 ! return ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine sigio_cnvtdvd !------------------------------------------------------------------------------- end module