source: LMDZ6/branches/LMDZ-tracers/libf/dyn3dmem/dynetat0_loc.F90 @ 3999

SUBROUTINE dynetat0_loc(fichnom,vcov,ucov,teta,q,masse,ps,phis,time)
!
!-------------------------------------------------------------------------------
! Authors: P. Le Van , L.Fairhead
!-------------------------------------------------------------------------------
! Purpose: Initial state reading.
!-------------------------------------------------------------------------------
  USE parallel_lmdz
  USE infotrac,    ONLY: nqtot, niso, tracers, iTraPha, tnat, alpha_ideal, tra
  USE netcdf, ONLY: NF90_OPEN,  NF90_INQUIRE_DIMENSION, NF90_INQ_VARID,        &
      NF90_NOWRITE, NF90_CLOSE, NF90_INQUIRE_VARIABLE,  NF90_GET_VAR,          &
      NF90_GET_ATT, NF90_NoErr, NF90_INQUIRE
  USE control_mod, ONLY: planet_type
  USE assert_eq_m, ONLY: assert_eq
  USE comvert_mod, ONLY: pa,preff
  USE comconst_mod, ONLY: cpp, daysec, dtvr, g, im, jm, kappa, lllm, omeg, rad
  USE logic_mod, ONLY: fxyhypb, ysinus
  USE serre_mod, ONLY: clon, clat, grossismx, grossismy
  USE temps_mod, ONLY: annee_ref, day_ini, day_ref, itau_dyn, start_time
  USE ener_mod,  ONLY: etot0, ptot0, ztot0, stot0, ang0
  USE strings_mod, ONLY: strIdx
  USE readTracFiles_mod, ONLY: known_phases, old_phases, nphases, phases_sep

  IMPLICIT NONE
  include "dimensions.h"
  include "paramet.h"
  include "comgeom.h"
  include "description.h"
  include "iniprint.h"
!===============================================================================
! Arguments:
  CHARACTER(LEN=*), INTENT(IN) :: fichnom          !--- FILE NAME
  REAL, INTENT(OUT) ::  vcov(ijb_v:ije_v,llm)      !--- V COVARIANT WIND
  REAL, INTENT(OUT) ::  ucov(ijb_u:ije_u,llm)      !--- U COVARIANT WIND
  REAL, INTENT(OUT) ::  teta(ijb_u:ije_u,llm)      !--- POTENTIAL TEMP.
  REAL, INTENT(OUT) ::     q(ijb_u:ije_u,llm,nqtot)!--- TRACERS
  REAL, INTENT(OUT) :: masse(ijb_u:ije_u,llm)      !--- MASS PER CELL
  REAL, INTENT(OUT) ::    ps(ijb_u:ije_u)          !--- GROUND PRESSURE
  REAL, INTENT(OUT) ::  phis(ijb_u:ije_u)          !--- GEOPOTENTIAL
!===============================================================================
! Local variables:
  CHARACTER(LEN=256) :: sdum, var, modname, oldH2O
  INTEGER, PARAMETER :: length=100
  INTEGER :: iq, fID, vID, idecal, ix, ip, ierr, ib, ie, nglo
  REAL    :: time, tab_cntrl(length)               !--- RUN PARAMS TABLE
  TYPE(tra), POINTER :: tr
!-------------------------------------------------------------------------------
  modname="dynetat0_loc"

!--- Initial state file opening
  var=fichnom
  CALL err(NF90_OPEN(var,NF90_NOWRITE,fID),"open",var)
  CALL get_var1("controle",tab_cntrl)

!!! AS: idecal is a hack to be able to read planeto starts...
!!!     .... while keeping everything OK for LMDZ EARTH
  IF(planet_type=="generic") THEN
    WRITE(lunout,*)'NOTE NOTE NOTE : Planeto-like start files'
    idecal = 4
    annee_ref  = 2000
  ELSE
    WRITE(lunout,*)'NOTE NOTE NOTE : Earth-like start files'
    idecal = 5
    annee_ref  = tab_cntrl(5)
  END IF
  im         = tab_cntrl(1)
  jm         = tab_cntrl(2)
  lllm       = tab_cntrl(3)
  day_ref    = tab_cntrl(4)
  rad        = tab_cntrl(idecal+1)
  omeg       = tab_cntrl(idecal+2)
  g          = tab_cntrl(idecal+3)
  cpp        = tab_cntrl(idecal+4)
  kappa      = tab_cntrl(idecal+5)
  daysec     = tab_cntrl(idecal+6)
  dtvr       = tab_cntrl(idecal+7)
  etot0      = tab_cntrl(idecal+8)
  ptot0      = tab_cntrl(idecal+9)
  ztot0      = tab_cntrl(idecal+10)
  stot0      = tab_cntrl(idecal+11)
  ang0       = tab_cntrl(idecal+12)
  pa         = tab_cntrl(idecal+13)
  preff      = tab_cntrl(idecal+14)
!
  clon       = tab_cntrl(idecal+15)
  clat       = tab_cntrl(idecal+16)
  grossismx  = tab_cntrl(idecal+17)
  grossismy  = tab_cntrl(idecal+18)
!
  IF ( tab_cntrl(idecal+19)==1. )  THEN
    fxyhypb  = .TRUE.
!   dzoomx   = tab_cntrl(25)
!   dzoomy   = tab_cntrl(26)
!   taux     = tab_cntrl(28)
!   tauy     = tab_cntrl(29)
  ELSE
    fxyhypb = .FALSE.
    ysinus  = tab_cntrl(idecal+22)==1.
  END IF

  day_ini    = tab_cntrl(30)
  itau_dyn   = tab_cntrl(31)
  start_time = tab_cntrl(32)

!-------------------------------------------------------------------------------
  WRITE(lunout,*)TRIM(modname)//': rad,omeg,g,cpp,kappa',rad,omeg,g,cpp,kappa
  CALL check_dim(im,iim,'im','im')
  CALL check_dim(jm,jjm,'jm','jm')
  CALL check_dim(lllm,llm,'lm','lllm')
  CALL get_var1("rlonu", rlonu)
  CALL get_var1("rlatu", rlatu)
  CALL get_var1("rlonv", rlonv)
  CALL get_var1("rlatv", rlatv)
  CALL get_var1("cu",       cu)
  CALL get_var1("cv",       cv)
  CALL get_var1("aire",   aire)

  var="temps"
  IF(NF90_INQ_VARID(fID,var,vID)/=NF90_NoErr) THEN
    WRITE(lunout,*)TRIM(modname)//": missing field <temps>"
    WRITE(lunout,*)TRIM(modname)//": trying with <Time>"; var="Time"
    CALL err(NF90_INQ_VARID(fID,var,vID),"inq",var)
  END IF
  CALL err(NF90_GET_VAR(fID,vID,time),"get",var)
  ib = ijb_v; ie = ije_v; nglo = ip1jm
  CALL get_var2("vcov",     vcov(ib:ie,:), ib, ie, nglo)
  ib = ijb_u; ie = ije_u; nglo = ip1jmp1
  CALL get_var2("ucov",     ucov(ib:ie,:), ib, ie, nglo)
  CALL get_var2("teta",     teta(ib:ie,:), ib, ie, nglo)
  CALL get_var2("masse",   masse(ib:ie,:), ib, ie, nglo)
  CALL get_var1("phisinit", phis(ib:ie),   ib, ie)
  CALL get_var1("ps",         ps(ib:ie),   ib, ie)

!--- Tracers
  DO iq=1,nqtot
    tr => tracers(iq)
    var = tr%name
    ix = strIdx([('H2O'//phases_sep//known_phases(ip:ip), ip=1, nphases)], var)
    oldH2O = '***'; IF(ix/=0) oldH2O = 'H2O'//old_phases(ix:ix)
    !------------------------------------------------------------------------------------------------------------------
    IF(NF90_INQ_VARID(fID, var, vID) == NF90_NoErr) THEN                                 !=== REGULAR CASE
      CALL get_var2(var, q(ib:ie,:,iq), ib, ie, nglo)
    !------------------------------------------------------------------------------------------------------------------
#ifdef INCA
    ELSE IF(NF90_INQ_VARID(fID, 'OX',   vID) == NF90_NoErr .AND. var == 'O3') THEN       !=== INCA: OX INSTEAD OF O3
      WRITE(lunout,*)TRIM(modname)//': Tracer <O3> is missing => initialized to OX'
      CALL get_var2('OX', q(ib:ie,:,iq), ib, ie, nglo)
#endif
    !------------------------------------------------------------------------------------------------------------------
    ELSE IF(NF90_INQ_VARID(fID, oldH2O, vID) == NF90_NoErr .AND. ix  /= 0   ) THEN       !=== OLD WATER PHASES
      WRITE(lunout,*)TRIM(modname)//': Tracer <'//TRIM(var)//'> is missing => initialized to '//TRIM(oldH2O)
      CALL get_var2(oldH2O, q(ib:ie,:,iq), ib, ie, nglo)
    !------------------------------------------------------------------------------------------------------------------
    ELSE IF(niso > 0 .AND. tr%iso_num > 0) THEN                                          !=== ISOTOPES, CRisi
      IF(tr%iso_zon == 0) THEN
        WRITE(lunout,*)TRIM(modname)//': Isotope <'//TRIM(var)//'> is missing => initialized with a' &
          //' simplified Rayleigh distillation law'
        q(:,:,iq) = q(:,:,tr%iprnt)         *        tnat(tr%iso_num) &
                  *(q(:,:,tr%iprnt)/30.e-3)**(alpha_ideal(tr%iso_num)-1)
      ELSE
        WRITE(lunout,*)TRIM(modname)//': Isotope geographical tracer <'//TRIM(var)//'> is missing '  &
          //'=> initialized its parent isotope concentration'
        q(:,:,iq) = q(:,:,iTraPha(tr%iso_num,tr%iso_pha))
      END IF
    !------------------------------------------------------------------------------------------------------------------
    ELSE                                                                                 !=== MISSING: SET TO 0
      WRITE(lunout,*)TRIM(modname)//': Tracer <'//TRIM(var)//'> is missing => initialized to zero'
      q(ib:ie,:,iq)=0.
    END IF
    !------------------------------------------------------------------------------------------------------------------
  END DO
  CALL err(NF90_CLOSE(fID),"close",fichnom)
  day_ini=day_ini+INT(time)
  time=time-INT(time)


  CONTAINS


SUBROUTINE check_dim(n1,n2,str1,str2)
  INTEGER,          INTENT(IN) :: n1, n2
  CHARACTER(LEN=*), INTENT(IN) :: str1, str2
  CHARACTER(LEN=256) :: s1, s2
  IF(n1/=n2) THEN
    s1='value of '//TRIM(str1)//' ='
    s2=' read in starting file differs from parametrized '//TRIM(str2)//' ='
    WRITE(sdum,'(10x,a,i4,2x,a,i4)'),TRIM(s1),n1,TRIM(s2),n2
    CALL ABORT_gcm(TRIM(modname),TRIM(sdum),1)
  END IF
END SUBROUTINE check_dim


SUBROUTINE get_var1(var, v, ib, ie)
!--- Usable for fields up to rank 4 with single time record (last index)
!--- Result: stacked in a vector. Used for 2D (single layer) fields.
  CHARACTER(LEN=*),  INTENT(IN)  :: var
  REAL,              INTENT(OUT) :: v(:)
  INTEGER, OPTIONAL, INTENT(IN)  :: ib, ie
  REAL, ALLOCATABLE :: w(:,:,:,:), v_glo(:)
  INTEGER :: n(4), dids(4), k, nd, ntot
  CALL err(NF90_INQ_VARID(fID, var, vID), "inq", var)
  ierr = NF90_INQUIRE_VARIABLE(fID, vID, dimids=dids, ndims=nd)
  n(:) = 1; DO k = 1, nd; ierr = NF90_INQUIRE_DIMENSION(fID, dids(k), len=n(k)); END DO
  IF(is_rec(fID, dids(nd)) .AND. n(nd) /= 1) &
    CALL abort_gcm(TRIM(modname), 'Several records records for <'//TRIM(var)//'>')
  ntot = PRODUCT(n(1:nd))
  ALLOCATE(w(n(1), n(2), n(3), n(4)), v_glo(ntot))
  CALL err(NF90_GET_VAR(fID, vID, w), "get", var)
  v_glo(:) = RESHAPE(w, [ntot]); DEALLOCATE(w)
  IF(PRESENT(ib).AND.PRESENT(ie)) THEN; v(:) = v_glo(ib:ie); ELSE; v(:) = v_glo(:); END IF
  DEALLOCATE(v_glo)
END SUBROUTINE get_var1


SUBROUTINE get_var2(var, v, ib, ie, n_glo)
!--- Usable for fields up to rank 4 with one or several time records (last index)
!--- Result: stacked in a 2D array (1st/2nd index: horizontal/vertical). Used for 3D (several layers) fields.
  CHARACTER(LEN=*), INTENT(IN)  :: var
  REAL,             INTENT(OUT) :: v(:,:)
  INTEGER,          INTENT(IN)  :: ib, ie, n_glo
  REAL, ALLOCATABLE :: w(:,:,:,:), v_glo(:,:)
  INTEGER :: n(4), dids(4), k, nd, nh, nv, tid
  CALL err(NF90_INQ_VARID(fID, var, vID), "inq", var)
  ierr = NF90_INQUIRE_VARIABLE(fID, vID, dimids=dids, ndims=nd)
  n(:) = 1; DO k = 1, nd; ierr = NF90_INQUIRE_DIMENSION(fID, dids(k), len=n(k)); END DO
  IF(is_rec(fID, dids(nd))) THEN
    IF(n(nd) /= 1)  CALL abort_gcm(TRIM(modname), 'Several records records for <'//TRIM(var)//'>.')
    nh = PRODUCT(n(1:nd-2)); nv = n(nd-1)
  ELSE
    nh = PRODUCT(n(1:nd  )); nv = n(nd)
  END IF
  IF(nh/=n_glo .OR. nv/=llm) CALL abort_gcm(TRIM(modname), 'Shape mismatch for "'//TRIM(var)//'"')
  ALLOCATE(w(n(1), n(2), n(3), n(4)), v_glo(nh,nv))
  CALL err(NF90_GET_VAR(fID, vID, w), "get", var)
  v_glo(:,:) = RESHAPE(w, [nh, nv]); DEALLOCATE(w)
  v(:,:) = v_glo(ib:ie,:)
  DEALLOCATE(v_glo)
END SUBROUTINE get_var2


LOGICAL FUNCTION is_rec(fID, did) RESULT(lrec)
!--- Check whether the file has a record dimension, detected as UNLIMITED diemnsion or using the attribute "units".
  INTEGER, INTENT(IN) :: fID, did
  INTEGER :: vid
  CHARACTER(LEN=256) :: recn, ratt
  !--- Check the "units" attribute of the last dimensional variable to detect record axis.
  lrec = NF90_INQUIRE_DIMENSION  (fID, did, name=recn)    == NF90_NOERR
  IF(lrec) lrec = NF90_INQ_VARID (fID, recn, vid)         == NF90_NOERR
  IF(lrec) lrec = NF90_GET_ATT   (fID, vid, "units", ratt)== NF90_NOERR
  IF(lrec) lrec = INDEX(ratt, " since ") /= 0
END FUNCTION is_rec


SUBROUTINE err(ierr, typ, nam)
  INTEGER,          INTENT(IN) :: ierr   !--- NetCDF ERROR CODE
  CHARACTER(LEN=*), INTENT(IN) :: typ    !--- TYPE OF OPERATION
  CHARACTER(LEN=*), INTENT(IN) :: nam    !--- FIELD/FILE NAME
  IF(ierr==NF90_NoERR) RETURN
  SELECT CASE(typ)
    CASE('inq');   sdum="Field <"//TRIM(nam)//"> is missing"
    CASE('get');   sdum="Reading failed for <"//TRIM(nam)//">"
    CASE('open');  sdum="File opening failed for <"//TRIM(nam)//">"
    CASE('close'); sdum="File closing failed for <"//TRIM(nam)//">"
  END SELECT
  CALL ABORT_gcm(TRIM(modname),TRIM(sdum),ierr)
END SUBROUTINE err

END SUBROUTINE dynetat0_loc