Changeset 3985 for LMDZ6/branches


Ignore:
Timestamp:
Sep 22, 2021, 6:11:35 PM (3 years ago)
Author:
dcugnet
Message:
  • fix of the delPhase function.
  • getvar1 and getvar2 fixed and modified to avoid the usage of files with several time records and make the calls rather short.
  • works again with iadv==0
  • no more issues with tracers numbers (nqo, nqtot, etc.)
  • fixes in the algebrical reduction routine used for "isotopes_parems.def" (containing simple expressions with variables that have to be substituted).
  • still to be validated numerically
Location:
LMDZ6/branches/LMDZ-tracers
Files:
1 added
6 edited
2 moved

Legend:

Unmodified
Added
Removed

  • LMDZ6/branches/LMDZ-tracers/DefLists/tracer.def

    r3961 r3985  
    1 4
    2 14 14 H2Ov
    3 10 10 H2Ol
    4 10 10 H2Oi
    5 00 00 Aga
     1&version=1.0
     2&lmdz
     3default phases=g  hadv=10  vadv=10  parent=air  type=tracer
     4H2O     phases=g  hadv=14  vadv=14
     5H2O     phases=ls
     6Aga               hadv=0   vadv=0

  • LMDZ6/branches/LMDZ-tracers/DefLists/tracer_RN_PB.def

    r3961 r3985  
    1 6
    2 14 14 H2Ov
    3 10 10 H2Ol
    4 10 10 H2Oi
    5 10 10 Aga
    6 10 10 RN
    7 10 10 PB
     1&version=1.0
     2&lmdz
     3default phases=g  hadv=10  vadv=10  parent=air  type=tracer
     4H2O     phases=g  hadv=14  vadv=14
     5H2O     phases=ls
     6Aga               hadv=0   vadv=0
     7RN,PB

  • LMDZ6/branches/LMDZ-tracers/arch/arch-X64_IRENE.fcm

    r3435 r3985  
    1010%PROD_FFLAGS         -O3 -axAVX,SSE4.2 -fp-model fast=2
    1111%DEV_FFLAGS          -fp-model strict -p -g -O2 -traceback -fp-stack-check
    12 %DEBUG_FFLAGS        -fp-model strict -p -g -traceback -fp-stack-check -ftrapuv
    13 #%DEBUG_FFLAGS        -fp-model strict -p -g -traceback -fp-stack-check -ftrapuv -check bounds,noarg_temp_created,pointers,stack,uninit -debug full -init=arrays -init=snan
     12#%DEBUG_FFLAGS        -fp-model strict -p -g -traceback -fp-stack-check -ftrapuv
     13%DEBUG_FFLAGS        -fp-model strict -p -g -traceback -fp-stack-check -ftrapuv -check bounds,noarg_temp_created,pointers,stack,uninit -debug full -init=arrays -init=snan
    1414%MPI_FFLAGS
    1515%OMP_FFLAGS          -qopenmp

  • LMDZ6/branches/LMDZ-tracers/libf/dyn3d_common/infotrac.F90

    r3963 r3985  
    22
    33  USE       strings_mod, ONLY: msg, find, strIdx,  strFind,  strHead, dispTable, testFile, cat, get_in,   &
    4                               fmsg, test, int2str, strParse, strTail, strReduce, strStack, modname
     4                              fmsg, test, int2str, strParse, strTail, strReduce, strStack, modname, reduceExpr
    55  USE readTracFiles_mod, ONLY: readTracersFiles, getKey_init, nphases, delPhase, old_phases, aliasTracer, &
    66            phases_sep, tran0, readIsotopesFile, getKey, known_phases, addPhase, indexUpdate, initIsotopes
    … …  
    202202  oldH2O        = ['H2Ov','H2Ol','H2Oi']
    203203
     204!  lerr = reduceExpr('1.0+-470.0/1000.',msg1)
     205!print*,msg1
     206!stop
     207
    204208  !--- MESSAGE ABOUT THE CHOSEN CONFIGURATION
    205209  CALL msg('type_trac='//TRIM(type_trac))
    … …  
    279283      IF(planet_type=='earth') THEN                                  !--- Default for Earth
    280284        nqo = 2; nbtr = 2
     285        ALLOCATE(tracers(nqo+nbtr))
    281286        tracers(:)%name = ['H2O'//phases_sep//'g', 'H2O'//phases_sep//'l', 'RN   ', 'PB   ']
    282287        tracers(:)%prnt = [tran0, tran0, tran0, tran0]
    … …  
    286291      ELSE                                                           !--- Default for other planets
    287292        nqo = 0; nbtr = 1
     293        ALLOCATE(tracers(nqo+nbtr))
    288294        tracers(:)%name = ['dummy']
    289295        tracers(:)%prnt = ['dummy']
    … …  
    354360  IF(.NOT.ALLOCATED(conv_flg)) conv_flg = [(1, it=1, nbtr)]
    355361  IF(.NOT.ALLOCATED( pbl_flg))  pbl_flg = [(1, it=1, nbtr)]
    356 !print*,'nqo, nbtr = ',nqo,nbtr
    357 !stop
    358 
    359 #ifdef CPP_StratAer
    360   IF (type_trac == 'coag') THEN
    361     nbtr_bin=0
    362     nbtr_sulgas=0
    363     DO iq = 1, nqtrue
    364       IF(tracers(iq)%name(1:3)=='BIN') nbtr_bin    = nbtr_bin   +1
    365       IF(tracers(iq)%name(1:3)=='GAS') nbtr_sulgas = nbtr_sulgas+1
    366       SELECT CASE(tracers(iq)%name)
    367         CASE('BIN01');    id_BIN01_strat = iq - nqo; CALL msg('id_BIN01_strat=', id_BIN01_strat)
    368         CASE('GASOCS');   id_OCS_strat   = iq - nqo; CALL msg('id_OCS_strat  =', id_OCS_strat)
    369         CASE('GASSO2');   id_SO2_strat   = iq - nqo; CALL msg('id_SO2_strat  =', id_SO2_strat)
    370         CASE('GASH2SO4'); id_H2SO4_strat = iq - nqo; CALL msg('id_H2SO4_strat=', id_H2SO4_strat)
    371         CASE('GASTEST');  id_TEST_strat  = iq - nqo; CALL msg('id_TEST_strat=' , id_TEST_strat)
    372       END SELECT
    373     END DO
    374     CALL msg('nbtr_bin      =',nbtr_bin)
    375     CALL msg('nbtr_sulgas   =',nbtr_sulgas)
    376   END IF
    377 #endif
    378362
    379363  !--- Transfert number of tracers to Reprobus
    … …  
    459443    WRITE(msg2,'(a,i2,a)')'iadv=',iad,' not implemented yet for'
    460444
    461     !--- ONLY TESTED VALUES FOR TRACERS FOR NOW: iadv = 14, 10 (and 0)
     445    !--- ONLY TESTED VALUES FOR TRACERS FOR NOW:               iadv = 14, 10 (and 0 for non-transported tracers)
    462446    IF(ALL( [10,14,0] /= iad) ) CALL abort_gcm(modname, TRIM(msg1)//' ; only iadv=10 and iadv=14 are tested !', 1)
    463447
    464     !--- ONLY TESTED VALUES FOR CHILDS  FOR NOW: iadv = 10     (CHILDS:  TRACERS OF GENERATION GREATER THAN 1)
     448    !--- ONLY TESTED VALUES FOR CHILDS FOR NOW:                iadv = 10     (CHILDS:  TRACERS OF GENERATION GREATER THAN 1)
    465449    IF(fmsg(iad/=10.AND.t1%igen>1,'WARNING ! '//TRIM(msg2)//' childs.  Setting iadv=10 for "'//TRIM(t1%name)//'".')) t1%iadv=10
    466450
    467     !--- ONLY TESTED VALUES FOR PARENTS FOR NOW: iadv = 14, 10 (PARENTS: TRACERS OF GENERATION 1)
    468     IF(t1%igen==1 .AND. ALL([10,14]/=iad)) CALL abort_gcm(modname, TRIM(msg2)//' parents: schemes 10 or 14 only !', 1)
    469 
    470     !--- iadv = 14 IS ONLY VALID FOR WATER VAPOUR
     451    !--- ONLY TESTED VALUES FOR PARENTS HAVING CHILDS FOR NOW: iadv = 14, 10 (PARENTS: TRACERS OF GENERATION 1)
     452    IF(ANY(ttr(:)%igen>1) .AND. t1%igen==1 .AND. ALL([10,14]/=iad)) &
     453      CALL abort_gcm(modname, TRIM(msg2)//' parents: schemes 10 or 14 only !', 1)
     454
     455    !--- ONLY VALID SCHEME NUMBER FOR WATER VAPOUR:            iadv = 14
    471456    IF(fmsg(iad==14 .AND. t1%name(1:5)/='H2O'//phases_sep//'g', 'WARNING ! '//TRIM(msg1)//', found for "' &
    472457                 //TRIM(t1%name)//'" but only valid for water vapour ! Setting iadv=10 for "'//TRIM(t1%name)//'".')) t1%iadv=10

  • LMDZ6/branches/LMDZ-tracers/libf/dyn3dmem/dynetat0_loc.F90

    r3957 r3985  
    77!-------------------------------------------------------------------------------
    88  USE parallel_lmdz
    9   USE readTracFiles_mod, ONLY: known_phases, old_phases, nphases, phases_sep
    109  USE infotrac,    ONLY: nqtot, niso, tracers, iTraPha, tnat, alpha_ideal, tra
    11   USE netcdf,      ONLY: NF90_OPEN,  NF90_NOWRITE, NF90_INQ_VARID, NF90_INQUIRE_DIMENSION, &
    12            NF90_INQUIRE, NF90_CLOSE, NF90_GET_VAR, NF90_NoErr,     NF90_INQUIRE_VARIABLE
    13   USE strings_mod, ONLY: strIdx
     10  USE netcdf, ONLY: NF90_OPEN,  NF90_INQUIRE_DIMENSION, NF90_INQ_VARID,        &
     11      NF90_NOWRITE, NF90_CLOSE, NF90_INQUIRE_VARIABLE,  NF90_GET_VAR,          &
     12      NF90_GET_ATT, NF90_NoErr, NF90_INQUIRE
    1413  USE control_mod, ONLY: planet_type
    1514  USE assert_eq_m, ONLY: assert_eq
    1615  USE comvert_mod, ONLY: pa,preff
    17   USE comconst_mod, ONLY: cpp, daysec, dtvr, g, im, jm, kappa, lllm, omeg, rad
     16  USE comconst_mod, ONLY: cpp, daysec, dtvr, g, im, jm, kappa, lllm, &
     17                          omeg, rad
    1818  USE logic_mod, ONLY: fxyhypb, ysinus
    1919  USE serre_mod, ONLY: clon, clat, grossismx, grossismy
    20   USE temps_mod, ONLY: annee_ref, day_ini, day_ref, itau_dyn, start_time
    21   USE ener_mod,  ONLY: etot0, ptot0, ztot0, stot0, ang0
     20  USE temps_mod, ONLY: annee_ref,day_ref,itau_dyn, &
     21                       start_time,day_ini
     22  USE ener_mod, ONLY: etot0,ptot0,ztot0,stot0,ang0
     23  USE strings_mod, ONLY: strIdx
     24  USE readTracFiles_mod, ONLY: known_phases, old_phases, nphases, phases_sep
    2225
    2326  IMPLICIT NONE
    … …  
    4144  CHARACTER(LEN=256) :: sdum, var, modname, oldH2O
    4245  INTEGER, PARAMETER :: length=100
    43   INTEGER :: iq, fID, vID, idecal, ix, ip, ierr
     46  INTEGER :: iq, fID, vID, idecal, ix, ip, ierr, ib, ie, nglo
    4447  REAL    :: time, tab_cntrl(length)               !--- RUN PARAMS TABLE
    4548  TYPE(tra), POINTER :: tr
    … …  
    122125  END IF
    123126  CALL err(NF90_GET_VAR(fID,vID,time),"get",var)
    124   CALL get_var1("phisinit", phis, ijb_u, ije_u, ip1jmp1)
    125   CALL get_var2("ucov",     ucov, ijb_u, ije_u, ip1jmp1)
    126   CALL get_var2("vcov",     vcov, ijb_v, ije_v, ip1jm)
    127   CALL get_var2("teta",     teta, ijb_u, ije_u, ip1jmp1)
    128   CALL get_var2("masse",   masse, ijb_u, ije_u, ip1jmp1)
    129   CALL get_var1("ps",         ps, ijb_u, ije_u, ip1jmp1)
     127  ib = ijb_v; ie = ije_v; nglo = ip1jm
     128  CALL get_var2("vcov",     vcov(ib:ie,:), ib, ie, nglo)
     129  ib = ijb_u; ie = ije_u; nglo = ip1jmp1
     130  CALL get_var2("ucov",     ucov(ib:ie,:), ib, ie, nglo)
     131  CALL get_var2("teta",     teta(ib:ie,:), ib, ie, nglo)
     132  CALL get_var2("masse",   masse(ib:ie,:), ib, ie, nglo)
     133  CALL get_var1("phisinit", phis(ib:ie),   ib, ie)
     134  CALL get_var1("ps",         ps(ib:ie),   ib, ie)
    130135
    131136!--- Tracers
    … …  
    135140    ix = strIdx([('H2O'//phases_sep//known_phases(ip:ip), ip=1, nphases)], var)
    136141    IF(NF90_INQ_VARID(fID, var, vID) == NF90_NoErr) THEN
    137       CALL get_var2(var, q(:,:,iq), ijb_u, ije_u, ip1jmp1)
     142      CALL get_var2(var, q(ib:ie,:,iq), ib, ie, nglo)
    138143#ifdef INCA
    139144    ELSE IF(NF90_INQ_VARID(fID, 'OX', vID) == NF90_NoErr .AND. var == 'O3') THEN
    140145      WRITE(lunout,*)TRIM(modname)//': Tracer <O3> is missing => initialized to OX'
    141       CALL get_var2('OX', q(:,:,iq), ijb_u, ije_u, ip1jmp1)
     146      CALL get_var2('OX', q(ib:ie,:,iq), ib, ie, nglo)
    142147#endif
    143148    ELSE IF(ix /= 0) THEN              !--- Old file, water: H2Ov/l/i instead of H2O-g/-l/-s
    … …  
    145150      IF(NF90_INQ_VARID(fID, oldH2O, vID) == NF90_NoErr) THEN
    146151        WRITE(lunout,*)TRIM(modname)//': Tracer <'//TRIM(var)//'> is missing => initialized to '//TRIM(oldH2O)
    147         CALL get_var2(oldH2O, q(:,:,iq), ijb_u, ije_u, ip1jmp1)
     152        CALL get_var2(oldH2O, q(ib:ie,:,iq), ib, ie, nglo)
    148153      END IF
    149154    ELSE
    150155      WRITE(lunout,*)TRIM(modname)//': Tracer <'//TRIM(var)//'> is missing => initialized to zero'
    151       q(ijb_u:ije_u,:,iq)=0.
     156      q(ib:ie,:,iq)=0.
    152157      !--- CRisi: for isotopes, theoretical initialization using very simplified Rayleigh distillation law
    153158      IF(niso > 0 .AND. tr%iso_num > 0) THEN
    … …  
    179184
    180185
    181 SUBROUTINE get_var1(var, v, ib, ie, n_glo)
     186SUBROUTINE get_var1(var, v, ib, ie)
     187!--- Usable for fields up to rank 4 with single time record (last index)
     188!--- Result: stacked in a vector. Used for 2D (single layer) fields.
    182189  CHARACTER(LEN=*),  INTENT(IN)  :: var
    183190  REAL,              INTENT(OUT) :: v(:)
    184   INTEGER, OPTIONAL, INTENT(IN)  :: ib, ie, n_glo
     191  INTEGER, OPTIONAL, INTENT(IN)  :: ib, ie
    185192  REAL, ALLOCATABLE :: w(:,:,:,:), v_glo(:)
    186   INTEGER :: nn(4), dids(4), k, nd, ntot
     193  INTEGER :: n(4), dids(4), k, nd, ntot
    187194  CALL err(NF90_INQ_VARID(fID, var, vID), "inq", var)
    188195  ierr = NF90_INQUIRE_VARIABLE(fID, vID, dimids=dids, ndims=nd)
    189   nn(:) = 1; DO k=1,nd; ierr = NF90_INQUIRE_DIMENSION(fID, dids(k), len=nn(k)); END DO
    190   ntot = PRODUCT(nn(1:nd))
    191   ALLOCATE(w(nn(1), nn(2), nn(3), nn(4)))
     196  n(:) = 1; DO k = 1, nd; ierr = NF90_INQUIRE_DIMENSION(fID, dids(k), len=n(k)); END DO
     197  IF(is_rec(fID, dids(nd)) .AND. n(nd) /= 1) &
     198    CALL abort_gcm(TRIM(modname), 'Several records records for <'//TRIM(var)//'>')
     199  ntot = PRODUCT(n(1:nd))
     200  ALLOCATE(w(n(1), n(2), n(3), n(4)), v_glo(ntot))
    192201  CALL err(NF90_GET_VAR(fID, vID, w), "get", var)
    193   ALLOCATE(v_glo(ntot)); v_glo=RESHAPE(w, [ntot]); DEALLOCATE(w)
    194   IF(PRESENT(n_glo).AND.PRESENT(ib).AND.PRESENT(ie)) THEN
    195     IF(ntot/=n_glo) CALL abort_gcm(TRIM(modname), 'Shape mismatch for "'//TRIM(var)//'"')
    196     v(ib:ie) = v_glo(ib:ie)
    197   ELSE
    198     v(:) = v_glo(:)
    199   END IF
     202  v_glo(:) = RESHAPE(w, [ntot]); DEALLOCATE(w)
     203  IF(PRESENT(ib).AND.PRESENT(ie)) THEN; v(:) = v_glo(ib:ie); ELSE; v(:) = v_glo(:); END IF
    200204  DEALLOCATE(v_glo)
    201205END SUBROUTINE get_var1
    … …  
    203207
    204208SUBROUTINE get_var2(var, v, ib, ie, n_glo)
     209!--- Usable for fields up to rank 4 with one or several time records (last index)
     210!--- Result: stacked in a 2D array (1st/2nd index: horizontal/vertical). Used for 3D (several layers) fields.
    205211  CHARACTER(LEN=*), INTENT(IN)  :: var
    206212  REAL,             INTENT(OUT) :: v(:,:)
    207213  INTEGER,          INTENT(IN)  :: ib, ie, n_glo
    208214  REAL, ALLOCATABLE :: w(:,:,:,:), v_glo(:,:)
    209   INTEGER :: nn(4), dids(4), k, nd, nh, nv, tid
     215  INTEGER :: n(4), dids(4), k, nd, nh, nv, tid
    210216  CALL err(NF90_INQ_VARID(fID, var, vID), "inq", var)
    211217  ierr = NF90_INQUIRE_VARIABLE(fID, vID, dimids=dids, ndims=nd)
    212   nn(:) = 1; DO k=1,nd; ierr = NF90_INQUIRE_DIMENSION(fID, dids(k), len=nn(k)); END DO
    213   IF(NF90_INQUIRE(fID, unlimitedDimId=tid) == NF90_NOERR) THEN
    214     nh = PRODUCT(nn(1:nd-2)); nv = nn(nd-1); nn(nd) = 1
     218  n(:) = 1; DO k = 1, nd; ierr = NF90_INQUIRE_DIMENSION(fID, dids(k), len=n(k)); END DO
     219  IF(is_rec(fID, dids(nd))) THEN
     220    IF(n(nd) /= 1)  CALL abort_gcm(TRIM(modname), 'Several records records for <'//TRIM(var)//'>.')
     221    nh = PRODUCT(n(1:nd-2)); nv = n(nd-1)
    215222  ELSE
    216     nh = PRODUCT(nn(1:nd-1)); nv = nn(nd)
    217   END IF
    218   ALLOCATE(w(nn(1), nn(2), nn(3), nn(4)))
     223    nh = PRODUCT(n(1:nd  )); nv = n(nd)
     224  END IF
     225  IF(nh/=n_glo .OR. nv/=llm) CALL abort_gcm(TRIM(modname), 'Shape mismatch for "'//TRIM(var)//'"')
     226  ALLOCATE(w(n(1), n(2), n(3), n(4)), v_glo(nh,nv))
    219227  CALL err(NF90_GET_VAR(fID, vID, w), "get", var)
    220   ALLOCATE(v_glo(nh, nv)); v_glo = RESHAPE(w, [nh, nv]); DEALLOCATE(w)
    221   IF(nh/=n_glo .OR. nv/=llm) CALL abort_gcm(TRIM(modname), 'Shape mismatch for "'//TRIM(var)//'"')
    222   v(ib:ie,:) = v_glo(ib:ie,:)
     228  v_glo(:,:) = RESHAPE(w, [nh, nv]); DEALLOCATE(w)
     229  v(:,:) = v_glo(ib:ie,:)
    223230  DEALLOCATE(v_glo)
    224231END SUBROUTINE get_var2
     232
     233
     234LOGICAL FUNCTION is_rec(fID, did) RESULT(lrec)
     235!--- Check whether the file has a record dimension, detected as UNLIMITED diemnsion or using the attribute "units".
     236  INTEGER, INTENT(IN) :: fID, did
     237  INTEGER :: vid
     238  CHARACTER(LEN=256) :: recn, ratt
     239  !--- Check the "units" attribute of the last dimensional variable to detect record axis.
     240  lrec = NF90_INQUIRE_DIMENSION  (fID, did, name=recn)    == NF90_NOERR
     241  IF(lrec) lrec = NF90_INQ_VARID (fID, recn, vid)         == NF90_NOERR
     242  IF(lrec) lrec = NF90_GET_ATT   (fID, vid, "units", ratt)== NF90_NOERR
     243  IF(lrec) lrec = INDEX(ratt, " since ") /= 0
     244END FUNCTION is_rec
    225245
    226246

  • LMDZ6/branches/LMDZ-tracers/libf/misc/readTracFiles_mod.f90

    r3957 r3985  
    106106
    107107  !--- TELLS WHAT WAS IS ABOUT TO BE USED
    108   IF(test(fmsg(fType==0, 'No adequate tracers description file(s) found ; default values will be used'), lerr)) RETURN
     108  IF( fmsg(fType==0, 'No adequate tracers description file(s) found ; default values will be used')) RETURN
    109109  CALL msg(fType==1, 'Trying to read old-style tracers description file "traceur.def"')
    110110  CALL msg(fType==2, 'Trying to read the new style multi-sections tracers description file "tracer.def"')
    … …  
    860860    !--- REDUCE THE EXPRESSIONS TO OBTAIN SCALARS AND TRANSFER THEM TO THE "isot" ISOTOPES DESCRIPTORS VECTOR
    861861    DO it = 1, SIZE(dBase(idb)%trac)
    862       is = strIdx(isot(iis)%keys(:)%name, dBase(idb)%trac(it)%name)  !--- Index of the "isot(iis)%keys(:)%name" tracer named "t%name"
     862      t => dBase(idb)%trac(it)
     863      is = strIdx(isot(iis)%keys(:)%name, t%name)                    !--- Index in "isot(iis)%keys(:)%name" of isotope "t%name"
    863864      IF(is == 0) CYCLE
    864       t => dBase(idb)%trac(it)
    865865      liso = reduceExpr(t%keys%val, vals)                            !--- Reduce expressions (for substituted variables)
    866       isot(iis)%keys(is)%key = PACK(t%keys%key, MASK=liso)
    867       isot(iis)%keys(is)%val = PACK(  vals,     MASK=liso)
     866      IF(test(ANY(liso), lerr)) RETURN                               !--- Some non-numerical elements were found
     867      isot(iis)%keys(is)%key = PACK(t%keys%key, MASK=.NOT.liso)
     868      isot(iis)%keys(is)%val = PACK(  vals,     MASK=.NOT.liso)
    868869    END DO
    869870
    … …  
    12281229ELEMENTAL CHARACTER(LEN=256) FUNCTION delPhase(s) RESULT(out)
    12291230  CHARACTER(LEN=*), INTENT(IN) :: s
    1230   INTEGER :: l, i
     1231  INTEGER :: l, i, ix
    12311232  out = s
    1232   IF(s == '') RETURN
    1233   i = INDEX(s, '_'); l = LEN_TRIM(s)
    1234   IF(i == 0) THEN
    1235     IF(s(l-1:l-1)==phases_sep .AND. INDEX(known_phases,s(l:l)) /= 0) out = s(1:l-2)
    1236   ELSE; i=i-1
    1237     IF(s(i-1:i-1)==phases_sep .AND. INDEX(known_phases,s(i:i)) /= 0) out = s(1:i-2)//s(i+1:l)
     1233  IF(s == '') RETURN                                                           !--- Empty string: nothing to do
     1234  !--- Index of found phase in "known_phases"
     1235  ix = MAXLOC( [(i, i=1,nphases)], MASK=[( INDEX(s, phases_sep//known_phases(i:i))/=0, i=1, nphases)], DIM=1 )
     1236  IF(ix == 0) RETURN                                                           !--- No phase pattern found
     1237  i = INDEX(s, phases_sep//known_phases(ix:ix))                                !--- Index of <sep><pha> pattern in "str"
     1238  l = LEN_TRIM(s)
     1239  IF(i == l-1) THEN                                                            !--- <var><sep><pha>       => return <var>
     1240    out = s(1:l-2)
     1241  ELSE IF(s(i+2:i+2) == '_') THEN                                              !--- <var><sep><pha>_<tag> => return <var>_<tag>
     1242    out = s(1:i-1)//s(i+2:l)
    12381243  END IF
    12391244END FUNCTION delPhase
    … …  
    12441249  INTEGER :: l, i
    12451250  out = s
    1246   IF(s == '') RETURN
    1247   i = INDEX(s, '_'); l = LEN_TRIM(s)
    1248   IF(i == 0) out =  TRIM(s)//phases_sep//pha
    1249   IF(i /= 0) out = s(1:i-1)//phases_sep//pha//'_'//s(i+1:l)
     1251  IF(s == '') RETURN                                                           !--- Empty string: nothing to do
     1252  i = INDEX(s, '_')                                                            !--- /=0 for <var>_<tag> tracers names
     1253  l = LEN_TRIM(s)
     1254  IF(i == 0) out =  TRIM(s)//phases_sep//pha                                   !--- <var>       => return <var><sep><pha>
     1255  IF(i /= 0) out = s(1:i-1)//phases_sep//pha//'_'//s(i+1:l)                    !--- <var>_<tag> => return <var><sep><pha>_<tag>
    12501256END FUNCTION addPhase_1
    12511257!------------------------------------------------------------------------------------------------------------------------------

  • LMDZ6/branches/LMDZ-tracers/libf/misc/strings_mod.F90

    r3957 r3985  
    187187!==============================================================================================================================
    188188!=== Extract the substring in front of the last (first if lFirst==TRUE) occurrence of separator "sep" in "str" ================
     189!=== Examples for str='a_b_c' and sep='_' and the bash command with the same effect:                           ================
     190!===    * strHead(..,.FALSE.) = 'a'           ${str%%$sep*}                                                    ================
     191!===    * strHead(..,.TRUE.)  = 'a_b'         ${str%$sep*}                                                     ================
    189192!==============================================================================================================================
    190193CHARACTER(LEN=256) FUNCTION strHead_1(str,sep,lFirst) RESULT(out)
    … …  
    215218    out = [(strHead_1(str(k),lFirst=.NOT.lf), k=1, SIZE(str))]
    216219  END IF
    217 
    218220END FUNCTION strHead_m
    219221!==============================================================================================================================
    220 !=== Extract the substring following the last (first if lFirst==TRUE) occurrence of separator "sep" in "str" ==================
     222!=== Extract the substring following the last (first if lFirst==TRUE) occurrence of separator "sep" in "str"   ================
     223!=== Examples for str='a_b_c' and sep='_' and the bash command with the same effect:                           ================
     224!===    * strHead(..,.FALSE.) = 'b_c'         ${str#*$sep}                                                     ================
     225!===    * strHead(..,.TRUE.)  = 'c'           ${str##*$sep}                                                    ================
    221226!==============================================================================================================================
    222227CHARACTER(LEN=256) FUNCTION strTail_1(str,sep,lFirst) RESULT(out)
    … …  
    430435  LOGICAL, OPTIONAL, INTENT(IN)  :: lSc                              !--- Care about nbs with front sign or in scient. notation
    431436
     437  INTEGER              :: idx0                                       !--- Used to display an identified non-numeric string
    432438  INTEGER, ALLOCATABLE :: ii(:)
    433439  LOGICAL              :: ll, ls
    … …  
    435441!  modname = 'strIdx'
    436442  lerr = .FALSE.
    437   idx = strIdx1(rawList, del, ibeg, idel)
    438   IF(.NOT.PRESENT(lSc))                     RETURN                  !--- No need to check exceptions for numbers => finished
    439   IF(.NOT.        lSc )                     RETURN                  !--- No need to check exceptions for numbers => finished
     443  idx = strIdx1(rawList, del, ibeg, idel)                            !--- del(idel) appears in "rawList" at position idx
     444  IF(.NOT.PRESENT(lSc))               RETURN                         !--- No need to check exceptions for numbers => finished
     445  IF(.NOT.        lSc )               RETURN                         !--- No need to check exceptions for numbers => finished
     446  IF(idx == 0) THEN                                                  !--- No element of "del" in "rawList":
     447    lerr = .NOT.is_numeric(rawList(ibeg:))                           !--- String must be a number
     448    IF(lerr) idx = LEN_TRIM(rawList); RETURN                         !--- Update idx => rawList(ibeg:idx-1) is the whole string
     449  END IF
     450  idx0 = idx
     451  IF(test(idx==1.AND.INDEX('+-',del(idel))/=0, lerr)) RETURN         !--- Front separator different from +/-: error
     452  IF(idx/=1.AND.is_numeric(rawList(ibeg:idx-1)))      RETURN         !--- The input string tail is a valid number
     453  idx = strIdx1(rawList, del, idx+1, idel)                           !---   => TO THE NEXT DELIMITER
    440454  IF(idx == 0) THEN
    441     lerr = .NOT.is_numeric(rawList(ibeg:)); RETURN                  !--- No separator detected: string must be a number
    442   END IF
    443   IF(test(idx==1.AND.INDEX('+-',del(idel))/=0, lerr)) RETURN        !--- Front separator different from +/-: error
    444   IF(is_numeric(rawList(ibeg:idx-1)))                 RETURN        !--- The input string tail is a valid number
    445   idx = strIdx1(rawList, del, idx+1, idel)                          !---   => TO THE NEXT DELIMITER
     455    lerr = .NOT.is_numeric(rawList(ibeg:))                           !--- No delimiter detected: string must be a number
     456    IF(lerr) idx = idx0; RETURN
     457  END IF
     458  idx0 = idx
     459  IF(is_numeric(rawList(ibeg:idx-1)))                 RETURN         !--- The input string tail is a valid number
     460  IF(test(          INDEX('eE',rawList(idx-1:idx-1)) /= 0  &         !--- Sole possible exception: scientific notation: E+/-
     461               .OR. INDEX('+-',del(idel)) /=0, lerr)) RETURN
     462  idx = strIdx1(rawList, del, idx+1, idel)                           !---   => TO THE NEXT DELIMITER
    446463  IF(idx == 0) THEN
    447     lerr = .NOT.is_numeric(rawList(ibeg:)); RETURN                  !--- No separator detected: string must be a number
    448   END IF
    449   IF(is_numeric(rawList(ibeg:idx-1)))                 RETURN        !--- The input string tail is a valid number
    450   IF(test(          INDEX('eE',rawList(idx-1:idx-1)) /= 0  &        !--- Sole possible exception: scientific notation: E+/-
    451                .OR. INDEX('+-',del(idel)) /=0, lerr)) RETURN
    452   idx = strIdx1(rawList, del, idx+1, idel)                          !---   => TO THE NEXT DELIMITER
    453   IF(idx == 0) THEN
    454     lerr = .NOT.is_numeric(rawList(ibeg:)); RETURN                  !--- No separator detected: string must be a number
     464    lerr = .NOT.is_numeric(rawList(ibeg:))                           !--- No separator detected: string must be a number
     465    IF(lerr) idx = idx0; RETURN
    455466  END IF
    456467  lerr = .NOT.is_numeric(rawList(ibeg:idx-1))
    457 
    458468CONTAINS
    459469
    … …  
    538548  DO
    539549    lerr = strIdx_prv(r, delimiter, ib, ie, jd, ll)
     550    IF(fmsg(lerr,'"'//TRIM(r(ib:ie-1))//'" is not numeric')) RETURN
    540551    IF(jd == 0) EXIT
    541     IF(fmsg(lerr,'"'//TRIM(r(ib:ie-1))//'" is not numeric')) RETURN
    542552    ib = ie + LEN(delimiter(jd))
    543553    DO WHILE(r(ib:ib) == ' ' .AND. ib < nr); ib = ib + 1; END DO     !--- Skip spaces before next chain
    … …  
    11171127!=== Reduce an algebrical expression (basic operations and parenthesis) to a single number (string format) ====================
    11181128!==============================================================================================================================
    1119 LOGICAL FUNCTION reduceExpr_1(str, val) RESULT(out)
     1129LOGICAL FUNCTION reduceExpr_1(str, val) RESULT(lerr)
    11201130  CHARACTER(LEN=*),    INTENT(IN)  :: str
    11211131  CHARACTER(LEN=256),  INTENT(OUT) :: val
    … …  
    11331143  ll = strCount(s,'(',nl)
    11341144  ll = strCount(s,')',nn)
    1135   out = nl == nn
    1136   IF(fmsg(.NOT.out, 'Mismatching number of opening and closing parenthesis: '//TRIM(s))) RETURN
     1145  lerr = nl /= nn
     1146  IF(fmsg(lerr, 'Mismatching number of opening and closing parenthesis: '//TRIM(s))) RETURN
    11371147  nl = 2*nl-1
    11381148
    … …  
    11521162  DO WHILE(nl > 1)
    11531163    i = 1; DO WHILE(ip(i) /= 1 .OR. ip(i+1) /= 2); i = i + 1; END DO !IF(i > SIZE(ip)+1) EXIT;END DO
    1154     out = reduceExpr_basic(vl(i+1), v); IF(.NOT. out) RETURN
     1164    IF(test(reduceExpr_basic(vl(i+1), v), lerr)) RETURN
    11551165    v = TRIM(vl(i))//TRIM(v); IF(i+2<=nl) v=TRIM(v)//TRIM(vl(i+2))
    11561166    vv = v//REPEAT(' ',768)
    … …  
    11601170    nl = SIZE(vl)
    11611171  END DO
    1162   out = reduceExpr_basic(vl(1), val)
     1172  lerr = reduceExpr_basic(vl(1), val)
    11631173END FUNCTION reduceExpr_1
    11641174
    … …  
    11671177!=== Reduce a simple algebrical expression (basic operations, no parenthesis) to a single number (string format) ==============
    11681178!==============================================================================================================================
    1169 LOGICAL FUNCTION reduceExpr_basic(str, val) RESULT(out)
     1179LOGICAL FUNCTION reduceExpr_basic(str, val) RESULT(lerr)
    11701180  CHARACTER(LEN=*),   INTENT(IN)  :: str
    11711181  CHARACTER(LEN=*),   INTENT(OUT) :: val
    … …  
    11781188  DOUBLE PRECISION :: v, vm, vp
    11791189  INTEGER      :: i, ni, io
    1180   LOGICAL :: ll
    11811190
    11821191!  modname = 'reduceExpr_basic'
    1183   out = .TRUE.
     1192  lerr = .FALSE.
    11841193  IF(is_numeric(str)) THEN; val=TRIM(str); RETURN; END IF
    11851194  op = ['^','/','*','+','-']                                                   !--- List of recognized operations
    11861195  s = str
    1187   ll = strParse_m(s, op, ky, .TRUE., id = id)                                  !--- Parse the values
     1196  IF(test(strParse_m(s, op, ky, .TRUE., id = id), lerr)) RETURN                !--- Parse the values
    11881197  vl = str2dble(ky)                                                            !--- Conversion to doubles
    1189   out = ALL(vl < HUGE(1.d0))
    1190   IF(fmsg(.NOT.out,'Some values are non-numeric in: '//TRIM(s))) RETURN        !--- Non-numerical values found
     1198  lerr = ANY(vl >= HUGE(1.d0))
     1199  IF(fmsg(lerr,'Some values are non-numeric in: '//TRIM(s))) RETURN            !--- Non-numerical values found
    11911200  DO io = 1, SIZE(op)                                                          !--- Loop on known operators (order matters !)
    11921201    DO i = SIZE(id), 1, -1                                                     !--- Loop on found operators
    … …  
    12111220
    12121221!==============================================================================================================================
    1213 FUNCTION reduceExpr_m(str, val) RESULT(out)
    1214   LOGICAL,            ALLOCATABLE              :: out(:)
     1222FUNCTION reduceExpr_m(str, val) RESULT(lerr)
     1223  LOGICAL,            ALLOCATABLE              :: lerr(:)
    12151224  CHARACTER(LEN=*),                INTENT(IN)  :: str(:)
    12161225  CHARACTER(LEN=256), ALLOCATABLE, INTENT(OUT) :: val(:)
    12171226  INTEGER :: i
    1218   ALLOCATE(out(SIZE(str)),val(SIZE(str)))
    1219   out(:) = [(reduceExpr_1(str(i), val(i)), i=1, SIZE(str))]
     1227  ALLOCATE(lerr(SIZE(str)),val(SIZE(str)))
     1228  lerr(:) = [(reduceExpr_1(str(i), val(i)), i=1, SIZE(str))]
    12201229END FUNCTION reduceExpr_m
    12211230!==============================================================================================================================
    … …  
    12301239  INTEGER :: e
    12311240  CHARACTER(LEN=12) :: fmt
     1241  IF(TRIM(str) == '') THEN; out = .FALSE.; RETURN; END IF
    12321242  WRITE(fmt,'("(f",i0,".0)")') LEN_TRIM(str)
    12331243  READ(str,fmt,IOSTAT=e) x

  • LMDZ6/branches/LMDZ-tracers/libf/phylmd/infotrac_phy.F90

    r3891 r3985  
    33  USE       strings_mod, ONLY: msg, fmsg, test, strIdx, int2str
    44
    5   USE readTracFiles_mod, ONLY: getKey_init, getKey, indexUpdate, delPhase
     5  USE readTracFiles_mod, ONLY: getKey_init, getKey, indexUpdate, delPhase, phases_sep, known_phases, nphases
    66
    77  USE trac_types_mod,    ONLY: tra, iso, kys
    … …  
    158158
    159159  CHARACTER(LEN=256) :: modname="init_infotrac_phy"
     160  INTEGER :: iq
    160161  LOGICAL :: lerr
    161162
    … …  
    188189#ifdef CPP_StratAer
    189190  IF (type_trac == 'coag') THEN
    190     nbtr_bin=0
    191     nbtr_sulgas=0
    192     DO iq = 1, nqtrue
    193       IF(tracers(iq)%name(1:3)=='BIN') nbtr_bin    = nbtr_bin   +1
    194       IF(tracers(iq)%name(1:3)=='GAS') nbtr_sulgas = nbtr_sulgas+1
    195       SELECT CASE(tracers(iq)%name)
    196         CASE('BIN01');    id_BIN01_strat = iq - nqo; CALL msg('id_BIN01_strat=', id_BIN01_strat)
    197         CASE('GASOCS');   id_OCS_strat   = iq - nqo; CALL msg('id_OCS_strat  =', id_OCS_strat)
    198         CASE('GASSO2');   id_SO2_strat   = iq - nqo; CALL msg('id_SO2_strat  =', id_SO2_strat)
    199         CASE('GASH2SO4'); id_H2SO4_strat = iq - nqo; CALL msg('id_H2SO4_strat=', id_H2SO4_strat)
    200         CASE('GASTEST');  id_TEST_strat  = iq - nqo; CALL msg('id_TEST_strat =', id_TEST_strat)
    201       END SELECT
    202     END DO
    203     CALL msg('nbtr_bin      =',nbtr_bin)
    204     CALL msg('nbtr_sulgas   =',nbtr_sulgas)
     191    nbtr_bin    = COUNT([(tracers(iq)%name(1:3)=='BIN', iq=1, nqtot)]); CALL msg('nbtr_bin       =', nbtr_bin)
     192    nbtr_sulgas = COUNT([(tracers(iq)%name(1:3)=='GAS', iq=1, nqtot)]); CALL msg('nbtr_sulgas    =', nbtr_sulgas)
     193    id_BIN01_strat = MAX(0, strIdx(tracers(:)%name, 'BIN01'   ) - nqo); CALL msg('id_BIN01_strat =', id_BIN01_strat)
     194    id_OCS_strat   = MAX(0, strIdx(tracers(:)%name, 'GASOSC'  ) - nqo); CALL msg('id_OCS_strat   =',   id_OCS_strat)
     195    id_SO2_strat   = MAX(0, strIdx(tracers(:)%name, 'GASSO2'  ) - nqo); CALL msg('id_SO2_strat   =',   id_SO2_strat)
     196    id_H2SO4_strat = MAX(0, strIdx(tracers(:)%name, 'GASH2SO4') - nqo); CALL msg('id_H2SO4_strat =', id_H2SO4_strat)
     197    id_TEST_strat  = MAX(0, strIdx(tracers(:)%name, 'GASTEST' ) - nqo); CALL msg('id_TEST_strat  =',  id_TEST_strat)
    205198  END IF
    206199#endif
Note: See TracChangeset for help on using the changeset viewer.