Changeset 2 for readTracFiles_mod.f90
- Timestamp:
- Dec 8, 2021, 9:25:11 PM (3 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
readTracFiles_mod.f90
r1 r2 1 1 MODULE readTracFiles_mod 2 2 3 USE strings_mod, ONLY: msg, testFile, strFind, strStack, strReduce, strHead, strCount, find, dispTable, fmsg, &4 removeComment, cat, checkList, strIdx, strParse, strReplace, strTail, reduceExpr, test, modname, get_in5 USE trac_types_mod, ONLY : tra , iso, db, kys3 USE strings_mod, ONLY: msg, testFile, strFind, strStack, strReduce, strHead, strCount, find, maxlen, fmsg, & 4 removeComment, cat, checkList, strIdx, strParse, strReplace, strTail, reduceExpr, test, get_in, dispTable 5 USE trac_types_mod, ONLY : trac_type, isot_type, keys_type 6 6 7 7 IMPLICIT NONE … … 10 10 11 11 PUBLIC :: initIsotopes 12 PUBLIC :: readTracersFiles, aliasTracer, tracersSubset, indexUpdate 13 PUBLIC :: readIsotopesFile 14 PUBLIC :: getKey_init, getKey, setDirectKeys !--- FUNCTIONS TO GET KEYS FROMtracers & isotopes15 16 PUBLIC :: known_phases, old_phases, nphases, phases_names, phases_sep, &!--- VARIABLES RELATED TO THE PHASES17 delPhase, addPhase !---ROUTINES TO ADD/REMOVE PHASE TO/FROM A NAME18 19 PUBLIC :: tran0, idxAncestor, ancestor !--- GEN 0 TRACER + TOOLS FOR GENERATIONS20 21 !------------------------------------------------------------------------------------------------------------------------------ 22 TYPE db!=== TYPE FOR TRACERS SECTION23 CHARACTER(LEN= 256):: name !--- Section name24 TYPE(tra ), ALLOCATABLE :: trac(:)!--- Tracers descriptors25 END TYPE d b12 PUBLIC :: readTracersFiles, aliasTracer, tracersSubset, indexUpdate!--- TOOLS ASSOCIATED TO TRACERS DESCRIPTORS 13 PUBLIC :: readIsotopesFile !--- TOOLS ASSOCIATED TO ISOTOPES DESCRIPTORS 14 PUBLIC :: getKey_init, getKey, setDirectKeys !--- GET/SET KEYS FROM/TO tracers & isotopes 15 16 PUBLIC :: known_phases, old_phases, nphases, phases_names, & !--- VARIABLES RELATED TO THE PHASES 17 phases_sep, delPhase, addPhase !--- + ROUTINES TO ADD/REMOVE PHASE TO/FROM A NAME 18 19 PUBLIC :: tran0, idxAncestor, ancestor !--- GENERATION 0 TRACER + TOOLS FOR GENERATIONS 20 21 !------------------------------------------------------------------------------------------------------------------------------ 22 TYPE :: dataBase_type !=== TYPE FOR TRACERS SECTION 23 CHARACTER(LEN=maxlen) :: name !--- Section name 24 TYPE(trac_type), ALLOCATABLE :: trac(:) !--- Tracers descriptors 25 END TYPE dataBase_type 26 26 !------------------------------------------------------------------------------------------------------------------------------ 27 27 INTERFACE getKey … … 29 29 END INTERFACE getKey 30 30 !------------------------------------------------------------------------------------------------------------------------------ 31 INTERFACE tracersSubset; MODULE PROCEDURE trSubset_Indx, trSubset_Name, trSubset_ Nam1; END INTERFACE tracersSubset31 INTERFACE tracersSubset; MODULE PROCEDURE trSubset_Indx, trSubset_Name, trSubset_gen0Name; END INTERFACE tracersSubset 32 32 INTERFACE idxAncestor; MODULE PROCEDURE idxAncestor_1, idxAncestor_m; END INTERFACE idxAncestor 33 33 INTERFACE ancestor; MODULE PROCEDURE ancestor_1, ancestor_m; END INTERFACE ancestor … … 36 36 37 37 !=== MAIN DATABASE: files sections descriptors 38 TYPE(d b), SAVE, ALLOCATABLE, TARGET :: dBase(:)38 TYPE(dataBase_type), SAVE, ALLOCATABLE, TARGET :: dBase(:) 39 39 40 40 !--- SOME PARAMETERS THAT ARE NOT LIKELY TO CHANGE OFTEN 41 CHARACTER(LEN= 256), SAVE :: tran0 = 'air'!--- Default transporting fluid42 CHARACTER(LEN= 256), PARAMETER :: old_phases = 'vli'!--- Old phases for water (no separator)43 CHARACTER(LEN= 256), PARAMETER :: known_phases = 'gls'!--- Known phases initials44 INTEGER, PARAMETER :: nphases = LEN_TRIM(known_phases)!--- Number of phases45 CHARACTER(LEN= 256), SAVE :: phases_names(nphases) &!--- Known phases names46 41 CHARACTER(LEN=maxlen), SAVE :: tran0 = 'air' !--- Default transporting fluid 42 CHARACTER(LEN=maxlen), PARAMETER :: old_phases = 'vli' !--- Old phases for water (no separator) 43 CHARACTER(LEN=maxlen), PARAMETER :: known_phases = 'gls' !--- Known phases initials 44 INTEGER, PARAMETER :: nphases=LEN_TRIM(known_phases) !--- Number of phases 45 CHARACTER(LEN=maxlen), SAVE :: phases_names(nphases) & !--- Known phases names 46 = ['gaseous', 'liquid ', 'solid '] 47 47 CHARACTER(LEN=1), SAVE :: phases_sep = '_' !--- Phase separator 48 48 LOGICAL, SAVE :: tracs_merge = .TRUE. !--- Merge/stack tracers lists … … 50 50 51 51 !=== LOCAL COPIES OF THE TRACERS AND ISOTOPES DESCRIPTORS, USED BY getKey (INITIALIZED IN getKey_init) 52 TYPE(tra), ALLOCATABLE, TARGET, SAVE :: tracers(:) 53 TYPE(iso), ALLOCATABLE, TARGET, SAVE :: isotopes(:) 54 52 TYPE(trac_type), ALLOCATABLE, TARGET, SAVE :: tracers(:) 53 TYPE(isot_type), ALLOCATABLE, TARGET, SAVE :: isotopes(:) 54 55 CHARACTER(LEN=maxlen) :: modname 55 56 56 57 CONTAINS … … 73 74 !=== FUNCTION RETURN VALUE "lerr" IS FALSE IN CASE SOMETHING WENT WRONG. 74 75 !=== ABOUT THE KEYS: 75 ! * The "keys" component (of type k ys) is in principle enough to store everything we could need.76 ! * The "keys" component (of type keys_type) is in principle enough to store everything we could need. 76 77 ! But some variables are stored as direct-access keys to make the code more readable and because they are used often. 77 78 ! * Most of the direct-access keys are set in this module, but some are not (lnam, iadv and itr for example). 78 79 ! * Some of the direct-access keys must be updated (using the routine "setDirectKeys") is a subset of "tracers(:)" 79 ! is extracted: the indexes are no longer valid for a subset (examples: tracers(:) iprnt or tracers(:)%ichld).80 ! is extracted: the indexes are no longer valid for a subset (examples: tracers(:)%iqParent or tracers(:)%ichld). 80 81 ! * If you need to convert a %key/%val pair into a direct-access key, add the corresponding line in "setDirectKeys". 81 82 !============================================================================================================================== 82 83 LOGICAL FUNCTION readTracersFiles(type_trac, fType, tracs) RESULT(lerr) 83 84 !------------------------------------------------------------------------------------------------------------------------------ 84 CHARACTER(LEN=*), INTENT(IN) :: type_trac!--- List of components used85 INTEGER, INTENT(OUT) :: fType!--- Type of input file found86 TYPE(tra ), ALLOCATABLE, INTENT(OUT) :: tracs(:)87 CHARACTER(LEN= 256),ALLOCATABLE :: s(:), sections(:), trac_files(:)88 CHARACTER(LEN= 256):: str, fname, mesg89 INTEGER :: is, nsec, ierr, it, ntrac, ns, ip90 LOGICAL, ALLOCATABLE :: ll(:), lGen3(:)85 CHARACTER(LEN=*), INTENT(IN) :: type_trac !--- List of components used 86 INTEGER, INTENT(OUT) :: fType !--- Type of input file found 87 TYPE(trac_type), ALLOCATABLE, INTENT(OUT) :: tracs(:) 88 CHARACTER(LEN=maxlen), ALLOCATABLE :: s(:), sections(:), trac_files(:) 89 CHARACTER(LEN=maxlen) :: str, fname, mesg 90 INTEGER :: is, nsec, ierr, it, ntrac, ns, ip 91 LOGICAL, ALLOCATABLE :: ll(:), lGen3(:) 91 92 !------------------------------------------------------------------------------------------------------------------------------ 92 93 lerr = .FALSE. 93 !modname = 'readTracersFiles'94 modname = 'readTracersFiles' 94 95 IF(.NOT.ALLOCATED(dBase)) ALLOCATE(dBase(0)) 95 96 … … 111 112 112 113 !--- TELLS WHAT WAS IS ABOUT TO BE USED 113 IF ( fmsg(fType==0, 'No adequate tracers description file(s) found ; default values will be used')) RETURN114 CALL msg( fType==1, 'Trying to read old-style tracers description file "traceur.def"')115 CALL msg( fType==2, 'Trying to read the new style multi-sections tracers description file "tracer.def"')116 CALL msg( fType==3, 'Trying to read the new style single section tracers description files "tracer_*.def"')114 IF (fmsg('No adequate tracers description file(s) found ; default values will be used', modname, fType==0)) RETURN 115 CALL msg('Trying to read old-style tracers description file "traceur.def"', modname, fType==1) 116 CALL msg('Trying to read the new style multi-sections tracers description file "tracer.def"', modname, fType==2) 117 CALL msg('Trying to read the new style single section tracers description files "tracer_*.def"', modname, fType==3) 117 118 118 119 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ … … 124 125 !--- GET THE TRACERS NUMBER 125 126 READ(90,'(i3)',IOSTAT=ierr)ntrac !--- Number of lines/tracers 126 IF(test(fmsg( ierr /= 0, 'Invalid format for "'//TRIM(fname)//'"'), lerr)) RETURN127 IF(test(fmsg('Invalid format for "'//TRIM(fname)//'"', modname, ierr /= 0), lerr)) RETURN 127 128 128 129 !--- READ THE REMAINING LINES: <hadv> <vadv> <tracer> [<transporting fluid>] … … 130 131 DO it=1,ntrac !=== READ RAW DATA: loop on the line/tracer number 131 132 READ(90,'(a)',IOSTAT=ierr) str 132 IF(test(fmsg( ierr>0, 'Invalid format for "' //TRIM(fname)//'"'), lerr)) RETURN133 IF(test(fmsg( ierr<0, 'Not enough lines in "'//TRIM(fname)//'"'), lerr)) RETURN133 IF(test(fmsg('Invalid format for "' //TRIM(fname)//'"', modname, ierr>0), lerr)) RETURN 134 IF(test(fmsg('Not enough lines in "'//TRIM(fname)//'"', modname, ierr<0), lerr)) RETURN 134 135 ll = strParse(str, ' ', s, n=ns) 135 136 tracs(it)%keys%key = ['hadv', 'vadv'] 136 137 tracs(it)%keys%val = s(1:2) 137 CALL msg( ns == 3 .AND. it == 1, 'This file is for air tracers only')138 CALL msg( ns == 4 .AND. it == 1, 'This files specifies the transporting fluid')139 tracs(it)%name = s(3); tracs(it)%phas = known_phases(1:1)!--- Default: name, gazeous phase "g"138 CALL msg('This file is for air tracers only', modname, ns == 3 .AND. it == 1) 139 CALL msg('This files specifies the transporting fluid', modname, ns == 4 .AND. it == 1) 140 tracs(it)%name = s(3); tracs(it)%phase = known_phases(1:1) !--- Default: name, gazeous phase "g" 140 141 DO ip = 1, nphases !--- Deal with old water names 141 142 IF(s(3) /= 'H2O'//old_phases(ip:ip)) CYCLE 142 tracs(it)%phas = known_phases(ip:ip); tracs(it)%name = 'H2O'//phases_sep//TRIM(tracs(it)%phas)143 tracs(it)%phase = known_phases(ip:ip); tracs(it)%name = 'H2O'//phases_sep//TRIM(tracs(it)%phase) 143 144 END DO 144 tracs(it)%p rnt = tran0!--- Default transporting fluid: Air145 IF(ns == 4) tracs(it)%p rnt = s(4)!--- Transporting fluid name145 tracs(it)%parent = tran0 !--- Default transporting fluid: Air 146 IF(ns == 4) tracs(it)%parent = s(4) !--- Transporting fluid name 146 147 END DO 147 148 CLOSE(90) 148 149 149 lGen3 = tracs%i gen==3150 CALL setGeneration(tracs) !--- Determine tracs(:)%i gen values150 lGen3 = tracs%iGeneration==3 151 CALL setGeneration(tracs) !--- Determine tracs(:)%iGeneration values 151 152 IF(test(checkTracers(tracs, fname,fname),lerr)) RETURN !--- Detect orphans and check phases 152 153 IF(test(checkUnique (tracs,lGen3,fname,fname),lerr)) RETURN !--- Detect repeated tracers … … 160 161 161 162 !=== USING NEW FORMAT TRACERS DESCRIPTION FILES WITH POSSIBLY SEVERAL SECTIONS 162 CALL msg( nsec > 1 .AND. tracs_merge, 'The multiple required sections will be MERGED.')163 CALL msg( nsec > 1 .AND. .NOT.tracs_merge, 'The multiple required sections will be CUMULATED.')163 CALL msg('The multiple required sections will be MERGED.', modname, nsec > 1 .AND. tracs_merge) 164 CALL msg('The multiple required sections will be CUMULATED.', modname, nsec > 1 .AND. .NOT.tracs_merge) 164 165 165 166 !=== FEED THE DATABASE WITH THE RAW CONTENT OF THE FILE … … 191 192 INTEGER, ALLOCATABLE :: ixf(:) !--- File index for each section of the expanded list 192 193 LOGICAL, ALLOCATABLE :: lTg(:) !--- Tagging tracers mask 193 CHARACTER(LEN= 256) :: fnm, snm194 CHARACTER(LEN=maxlen) :: fnm, snm, modname 194 195 INTEGER :: idb, i 195 196 LOGICAL :: ll 196 197 !------------------------------------------------------------------------------------------------------------------------------ 197 198 modname = 'feedDBase' 198 199 !=== READ THE REQUIRED SECTIONS 199 200 ll = strCount(snames, ',', ndb) !--- Number of sections for each file … … 219 220 220 221 !=== DISPLAY BASIC INFORMATION 221 lerr = ANY([(dispTraSection('Expanded list for section "'//TRIM(dBase(idb)%name)//'"',dBase(idb)%name), idb=1, SIZE(dBase))]) 222 lerr = ANY([( dispTraSection('Expanded list for section "'//TRIM(dBase(idb)%name)//'"', dBase(idb)%name, modname), & 223 idb=1, SIZE(dBase) )]) 222 224 END FUNCTION feedDBase 223 225 !------------------------------------------------------------------------------------------------------------------------------ … … 230 232 CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: defName !--- Special section (default values) name 231 233 !------------------------------------------------------------------------------------------------------------------------------ 232 TYPE(d b),ALLOCATABLE :: tdb(:)233 CHARACTER(LEN= 256), ALLOCATABLE :: sec(:)234 INTEGER, ALLOCATABLE :: ix(:)234 TYPE(dataBase_type), ALLOCATABLE :: tdb(:) 235 CHARACTER(LEN=maxlen), ALLOCATABLE :: sec(:) 236 INTEGER, ALLOCATABLE :: ix(:) 235 237 INTEGER :: n0, idb, ndb, i, j 236 238 LOGICAL :: ll … … 252 254 SUBROUTINE readSections_all() 253 255 !------------------------------------------------------------------------------------------------------------------------------ 254 CHARACTER(LEN= 256), ALLOCATABLE :: s(:), v(:)255 TYPE(tra ),ALLOCATABLE :: tt(:)256 TYPE(tra ):: tmp257 CHARACTER(LEN=1024) :: str258 CHARACTER(LEN= 256):: secn259 INTEGER :: ierr, n256 CHARACTER(LEN=maxlen), ALLOCATABLE :: s(:), v(:) 257 TYPE(trac_type), ALLOCATABLE :: tt(:) 258 TYPE(trac_type) :: tmp 259 CHARACTER(LEN=1024) :: str 260 CHARACTER(LEN=maxlen) :: secn 261 INTEGER :: ierr, n 260 262 !------------------------------------------------------------------------------------------------------------------------------ 261 263 IF(.NOT.ALLOCATED(dBase)) ALLOCATE(dBase(0)) … … 280 282 ll = strParse(str,' ', keys = s, vals = v, n = n) !--- Parse <key>=<val> pairs 281 283 tt = dBase(ndb)%trac(:) 282 tmp%name = s(1); tmp%comp =secn; tmp%keys = kys(s(1), s(2:n), v(2:n))284 tmp%name = s(1); tmp%component=secn; tmp%keys = keys_type(s(1), s(2:n), v(2:n)) 283 285 dBase(ndb)%trac = [tt(:), tmp] 284 286 DEALLOCATE(tt) 285 ! dBase(ndb)%trac = [dBase(ndb)%trac(:), tra(name=s(1), comp=secn, keys=k ys(s(1), s(2:n), v(2:n)))]287 ! dBase(ndb)%trac = [dBase(ndb)%trac(:), tra(name=s(1), comp=secn, keys=keys_type(s(1), s(2:n), v(2:n)))] 286 288 END IF 287 289 END DO … … 300 302 ! Purpose: Add the keys from virtual tracer named "defName" (if any) and remove this virtual tracer. 301 303 !------------------------------------------------------------------------------------------------------------------------------ 302 TYPE(tra ), ALLOCATABLE, TARGET, INTENT(INOUT) :: t(:)303 CHARACTER(LEN=*), INTENT(IN) :: defName304 TYPE(trac_type), ALLOCATABLE, TARGET, INTENT(INOUT) :: t(:) 305 CHARACTER(LEN=*), INTENT(IN) :: defName 304 306 INTEGER :: jd, it, k 305 TYPE(k ys), POINTER :: ky306 TYPE(tra ), ALLOCATABLE :: tt(:)307 TYPE(keys_type), POINTER :: ky 308 TYPE(trac_type), ALLOCATABLE :: tt(:) 307 309 jd = strIdx(t(:)%name, defName) 308 310 IF(jd == 0) RETURN … … 321 323 ! Substitute the keys locally (for the current tracer) if the flag "lSubLocal" is .TRUE. 322 324 !------------------------------------------------------------------------------------------------------------------------------ 323 TYPE(tra ), ALLOCATABLE, TARGET, INTENT(INOUT) :: t(:)324 CHARACTER(LEN=*), INTENT(IN) :: defName325 LOGICAL, INTENT(IN) :: lSubLocal325 TYPE(trac_type), ALLOCATABLE, TARGET, INTENT(INOUT) :: t(:) 326 CHARACTER(LEN=*), INTENT(IN) :: defName 327 LOGICAL, INTENT(IN) :: lSubLocal 326 328 INTEGER :: i0, it, ik 327 TYPE(k ys), POINTER :: k0, ky328 TYPE(tra ), ALLOCATABLE :: tt(:)329 TYPE(keys_type), POINTER :: k0, ky 330 TYPE(trac_type), ALLOCATABLE :: tt(:) 329 331 i0 = strIdx(t(:)%name, defName) 330 332 IF(i0 == 0) RETURN … … 353 355 ! * Default values are provided for these keys because they are necessary. 354 356 !------------------------------------------------------------------------------------------------------------------------------ 355 TYPE(tra ),ALLOCATABLE, INTENT(INOUT) :: tr(:) !--- Tracer derived type vector356 CHARACTER(LEN=*), INTENT(IN) :: sname357 CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: fname358 TYPE(tra ),ALLOCATABLE :: ttr(:)359 CHARACTER(LEN= 256), ALLOCATABLE :: ta(:), pa(:)360 CHARACTER(LEN= 256) :: msg1357 TYPE(trac_type), ALLOCATABLE, INTENT(INOUT) :: tr(:) !--- Tracer derived type vector 358 CHARACTER(LEN=*), INTENT(IN) :: sname 359 CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: fname 360 TYPE(trac_type), ALLOCATABLE :: ttr(:) 361 CHARACTER(LEN=maxlen), ALLOCATABLE :: ta(:), pa(:) 362 CHARACTER(LEN=maxlen) :: msg1, modname 361 363 INTEGER :: it, nt, iq, nq, itr, ntr, ipr, npr, i 362 364 LOGICAL :: ll 365 modname = 'expandSection' 363 366 lerr = .FALSE. 364 367 nt = SIZE(tr) … … 368 371 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 369 372 !--- Extract useful keys: parent name, type, component name 370 tr(it)%p rnt= fgetKey(it, 'parent', tr(:)%keys, tran0 )371 tr(it)%type = fgetKey(it, 'type' , tr(:)%keys, 'tracer')372 tr(it)%comp = sname373 tr(it)%parent = fgetKey(it, 'parent', tr(:)%keys, tran0 ) 374 tr(it)%type = fgetKey(it, 'type' , tr(:)%keys, 'tracer') 375 tr(it)%component = sname 373 376 374 377 !--- Determine the number of tracers and parents ; coherence checking 375 ll = strCount(tr(it)%name, ',', ntr)376 ll = strCount(tr(it)%p rnt, ',', npr)378 ll = strCount(tr(it)%name, ',', ntr) 379 ll = strCount(tr(it)%parent, ',', npr) 377 380 378 381 !--- Tagging tracers only can have multiple parents … … 380 383 msg1 = 'Check section "'//TRIM(sname)//'"' 381 384 IF(PRESENT(fname)) msg1=TRIM(msg1)//' in file "'//TRIM(fname)//'"' 382 CALL msg(TRIM(msg1)//': "'//TRIM(tr(it)%name)//'" has several parents but is not a tag' ); RETURN385 CALL msg(TRIM(msg1)//': "'//TRIM(tr(it)%name)//'" has several parents but is not a tag', modname); RETURN 383 386 END IF 384 387 nq = nq + ntr*npr … … 394 397 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 395 398 ll = strParse(tr(it)%name, ',', ta, n=ntr) !--- Number of tracers 396 ll = strParse(tr(it)%p rnt, ',', pa, n=npr)!--- Number of parents399 ll = strParse(tr(it)%parent, ',', pa, n=npr) !--- Number of parents 397 400 DO ipr=1,npr !--- Loop on parents list elts 398 401 DO itr=1,ntr !--- Loop on tracers list elts 399 402 i = iq+itr-1+(ipr-1)*ntr 400 ttr(i)%name = ta(itr); ttr(i)%p rnt = pa(ipr)401 ttr(i)%keys = k ys(ta(itr), tr(it)%keys%key, tr(it)%keys%val)403 ttr(i)%name = ta(itr); ttr(i)%parent = pa(ipr) 404 ttr(i)%keys = keys_type(ta(itr), tr(it)%keys%key, tr(it)%keys%val) 402 405 END DO 403 406 END DO … … 421 424 !------------------------------------------------------------------------------------------------------------------------------ 422 425 ! Arguments: 423 TYPE(tra ), INTENT(INOUT) :: tr(:)!--- Tracer derived type vector426 TYPE(trac_type), INTENT(INOUT) :: tr(:) !--- Tracer derived type vector 424 427 !------------------------------------------------------------------------------------------------------------------------------ 425 428 ! Local variables: 426 429 INTEGER :: iq, nq, ig 427 LOGICAL, ALLOCATABLE :: lg(:)428 CHARACTER(LEN= 256), ALLOCATABLE :: prn(:)429 !------------------------------------------------------------------------------------------------------------------------------ 430 tr(:)%i gen = 0!--- error if 0430 LOGICAL, ALLOCATABLE :: lg(:) 431 CHARACTER(LEN=maxlen), ALLOCATABLE :: prn(:) 432 !------------------------------------------------------------------------------------------------------------------------------ 433 tr(:)%iGeneration = 0 !--- error if 0 431 434 nq = SIZE(tr, DIM=1) !--- Number of tracers lines 432 lg = tr(:)%p rnt == tran0!--- First generation tracers flag433 WHERE(lg) tr(:)%i gen = 1!--- First generation tracers435 lg = tr(:)%parent == tran0 !--- First generation tracers flag 436 WHERE(lg) tr(:)%iGeneration = 1 !--- First generation tracers 434 437 435 438 !=== Determine generation for each tracer 436 439 ig=0; prn = [tran0] 437 440 DO !--- Update current generation flag 438 IF(ig/=0) prn = PACK( tr(:)%name, MASK=tr(:)%i gen == ig)439 lg(:) = [(ANY(prn(:) == tr(iq)%p rnt), iq=1, nq)]!--- Current generation tracers flag441 IF(ig/=0) prn = PACK( tr(:)%name, MASK=tr(:)%iGeneration == ig) 442 lg(:) = [(ANY(prn(:) == tr(iq)%parent), iq=1, nq)] !--- Current generation tracers flag 440 443 IF( ALL( .NOT. lg ) ) EXIT !--- Empty current generation 441 ig = ig+1; WHERE(lg) tr(:)%i gen = ig442 END DO 443 tr(:)% nam1 = ancestor(tr)!--- First generation ancestor name444 ig = ig+1; WHERE(lg) tr(:)%iGeneration = ig 445 END DO 446 tr(:)%gen0Name = ancestor(tr) !--- First generation ancestor name 444 447 445 448 END SUBROUTINE setGeneration … … 453 456 ! * check wether the phases are known or not ("g"aseous, "l"iquid or "s"olid so far) 454 457 !------------------------------------------------------------------------------------------------------------------------------ 455 TYPE(tra ),INTENT(IN) :: tr(:) !--- Tracer derived type vector458 TYPE(trac_type), INTENT(IN) :: tr(:) !--- Tracer derived type vector 456 459 CHARACTER(LEN=*), INTENT(IN) :: sname !--- Section name 457 460 CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: fname !--- File name 458 CHARACTER(LEN= 256) :: mesg459 CHARACTER(LEN= 256) :: bp(SIZE(tr, DIM=1)), pha!--- Bad phases list, phases of current tracer461 CHARACTER(LEN=maxlen) :: mesg 462 CHARACTER(LEN=maxlen) :: bp(SIZE(tr, DIM=1)), pha !--- Bad phases list, phases of current tracer 460 463 CHARACTER(LEN=1) :: p 461 464 INTEGER :: ip, np, iq, nq … … 466 469 467 470 !=== CHECK FOR ORPHAN TRACERS 468 IF(test(checkList(tr%name, tr%i gen==0, mesg, 'tracers', 'orphan'), lerr)) RETURN471 IF(test(checkList(tr%name, tr%iGeneration==0, mesg, 'tracers', 'orphan'), lerr)) RETURN 469 472 470 473 !=== CHECK PHASES 471 DO iq=1,nq; IF(tr(iq)%i gen/=1) CYCLE!--- Generation 1 only is checked474 DO iq=1,nq; IF(tr(iq)%iGeneration/=1) CYCLE !--- Generation 1 only is checked 472 475 pha = fgetKey(iq, 'phases', tr(:)%keys, 'g') !--- Phases 473 476 np = LEN_TRIM(pha); bp(iq)=' ' … … 475 478 IF(TRIM(bp(iq)) /= '') bp(iq) = TRIM(tr(iq)%name)//': '//TRIM(bp(iq)) 476 479 END DO 477 lerr = checkList(bp, tr%i gen==1 .AND. bp/='', mesg, 'tracers phases', 'unknown')480 lerr = checkList(bp, tr%iGeneration==1 .AND. bp/='', mesg, 'tracers phases', 'unknown') 478 481 END FUNCTION checkTracers 479 482 !============================================================================================================================== … … 484 487 ! Purpose: Make sure that tracers are not repeated. 485 488 !------------------------------------------------------------------------------------------------------------------------------ 486 TYPE(tra ),INTENT(IN) :: tr(:) !--- Tracer derived type vector489 TYPE(trac_type), INTENT(IN) :: tr(:) !--- Tracer derived type vector 487 490 LOGICAL, INTENT(IN) :: lTag(:) !--- Tagging tracer flag 488 491 CHARACTER(LEN=*), INTENT(IN) :: sname !--- Section name … … 490 493 !------------------------------------------------------------------------------------------------------------------------------ 491 494 INTEGER :: ip, np, iq, nq, k 492 LOGICAL, ALLOCATABLE :: ll(:)493 CHARACTER(LEN= 256) :: mesg, tnam, tdup(SIZE(tr,DIM=1))494 CHARACTER(LEN=1) :: p495 LOGICAL, ALLOCATABLE :: ll(:) 496 CHARACTER(LEN=maxlen) :: mesg, tnam, tdup(SIZE(tr,DIM=1)) 497 CHARACTER(LEN=1) :: p 495 498 !------------------------------------------------------------------------------------------------------------------------------ 496 499 mesg = 'Check section "'//TRIM(sname)//'"' … … 502 505 ll = tr(:)%name==tnam !--- Mask for current tracer name 503 506 IF(COUNT(ll)==1 ) CYCLE !--- Tracer is not repeated 504 IF(tr(iq)%i gen>1) THEN507 IF(tr(iq)%iGeneration>1) THEN 505 508 tdup(iq) = tnam !--- gen>1: MUST be unique 506 509 ELSE … … 524 527 ! Purpose: Expand the phases in the tracers descriptor "tr". 525 528 !------------------------------------------------------------------------------------------------------------------------------ 526 TYPE(tra ), ALLOCATABLE, INTENT(INOUT) :: tr(:)!--- Tracer derived type vector527 !------------------------------------------------------------------------------------------------------------------------------ 528 TYPE(tra ), ALLOCATABLE :: ttr(:)529 INTEGER, ALLOCATABLE :: i0(:)530 CHARACTER(LEN= 256):: nam, pha, trn529 TYPE(trac_type), ALLOCATABLE, INTENT(INOUT) :: tr(:) !--- Tracer derived type vector 530 !------------------------------------------------------------------------------------------------------------------------------ 531 TYPE(trac_type), ALLOCATABLE :: ttr(:) 532 INTEGER, ALLOCATABLE :: i0(:) 533 CHARACTER(LEN=maxlen) :: nam, pha, trn 531 534 INTEGER :: ip, np, iq, jq, nq, it, nt, nc, i, n 532 535 LOGICAL :: lTg, lEx … … 535 538 nt = 0 536 539 DO iq = 1, nq !--- GET THE NUMBER OF TRACERS 537 IF(tr(iq)%i gen /= 1) CYCLE538 nc = COUNT(tr(:)% nam1==tr(iq)%name .AND. tr%igen/=1)!--- Number of childs of tr(iq)539 tr(iq)%phas = fgetKey(iq, 'phases', tr(:)%keys)!--- Phases list of tr(iq)540 np = LEN_TRIM(tr(iq)%phas )!--- Number of phases of tr(iq)540 IF(tr(iq)%iGeneration /= 1) CYCLE 541 nc = COUNT(tr(:)%gen0Name==tr(iq)%name .AND. tr%iGeneration/=1) !--- Number of childs of tr(iq) 542 tr(iq)%phase = fgetKey(iq, 'phases', tr(:)%keys) !--- Phases list of tr(iq) 543 np = LEN_TRIM(tr(iq)%phase) !--- Number of phases of tr(iq) 541 544 nt = nt + (1+nc) * np !--- Number of tracers after expansion 542 545 END DO … … 545 548 DO iq = 1, nq !--- Loop on "tr(:)" indexes 546 549 lTg = tr(iq)%type=='tag' !--- Current tracer is a tag 547 i0 = strFind(tr(:)%name, tr(iq)% nam1, n)!--- Indexes of first generation ancestor copies548 np = SUM( [( LEN_TRIM(tr(i0(i))%phas ),i=1,n )],1)!--- Number of phases for current tracer tr(iq)550 i0 = strFind(tr(:)%name, tr(iq)%gen0Name, n) !--- Indexes of first generation ancestor copies 551 np = SUM( [( LEN_TRIM(tr(i0(i))%phase),i=1,n )],1) !--- Number of phases for current tracer tr(iq) 549 552 lEx = np>1 !--- Need of a phase suffix 550 IF(lTg) lEx=lEx.AND.tr(iq)%i gen>1!--- No phase suffix for first generation tags553 IF(lTg) lEx=lEx.AND.tr(iq)%iGeneration>1 !--- No phase suffix for first generation tags 551 554 DO i=1,n !=== LOOP ON FIRST GENERATION ANCESTORS 552 555 jq=i0(i) !--- tr(jq): ith copy of 1st gen. ancestor of tr(iq) 553 IF(tr(iq)%i gen==1) jq=iq!--- Generation 1: current tracer phases only554 pha = tr(jq)%phas 556 IF(tr(iq)%iGeneration==1) jq=iq !--- Generation 1: current tracer phases only 557 pha = tr(jq)%phase !--- Phases list for tr(jq) 555 558 DO ip=1,LEN_TRIM(pha) !=== LOOP ON PHASES LISTS 556 559 trn=TRIM(tr(iq)%name); nam=trn !--- Tracer name (regular case) 557 IF(lTg) nam = TRIM(tr(iq)%p rnt)!--- Parent name (tagging case)560 IF(lTg) nam = TRIM(tr(iq)%parent) !--- Parent name (tagging case) 558 561 IF(lEx) nam = TRIM(nam)//phases_sep//pha(ip:ip) !--- Phase extension needed 559 562 IF(lTg) nam = TRIM(nam)//'_'//TRIM(trn) !--- <parent>_<name> for tags … … 561 564 ttr(it)%name = nam !--- Name with possibly phase suffix 562 565 ttr(it)%keys%name = nam !--- Name inside the keys decriptor 563 ttr(it)%phas = pha(ip:ip)!--- Single phase entry564 IF(lEx.AND.tr(iq)%i gen>1) THEN565 ttr(it)%p rnt = TRIM(ttr(it)%prnt)//phases_sep//pha(ip:ip)566 ttr(it)% nam1 = TRIM(ttr(it)%nam1)//phases_sep//pha(ip:ip)566 ttr(it)%phase = pha(ip:ip) !--- Single phase entry 567 IF(lEx.AND.tr(iq)%iGeneration>1) THEN 568 ttr(it)%parent = TRIM(ttr(it)%parent)//phases_sep//pha(ip:ip) 569 ttr(it)%gen0Name = TRIM(ttr(it)%gen0Name)//phases_sep//pha(ip:ip) 567 570 END IF 568 571 it=it+1 569 572 END DO 570 IF(tr(iq)%i gen==1) EXIT!--- Break phase loop for gen 1573 IF(tr(iq)%iGeneration==1) EXIT !--- Break phase loop for gen 1 571 574 END DO 572 575 END DO … … 584 587 ! * lGrowGen == F: tracer + its childs sorted by growing generation, one after the other. 585 588 !------------------------------------------------------------------------------------------------------------------------------ 586 TYPE(tra ), ALLOCATABLE, INTENT(INOUT) :: tr(:)!--- Tracer derived type vector589 TYPE(trac_type), ALLOCATABLE, INTENT(INOUT) :: tr(:) !--- Tracer derived type vector 587 590 INTEGER :: ig, ng, iq, jq, n, ix(SIZE(tr)), k 588 591 INTEGER, ALLOCATABLE :: iy(:), iz(:) … … 590 593 iq = 1 591 594 IF(lSortByGen) THEN 592 ng = MAXVAL(tr(:)%i gen, MASK=.TRUE., DIM=1)!--- Number of generations595 ng = MAXVAL(tr(:)%iGeneration, MASK=.TRUE., DIM=1) !--- Number of generations 593 596 DO ig = 0, ng !--- Loop on generations 594 iy = PACK([(k, k=1, SIZE(tr))], MASK=tr(:)%i gen==ig)!--- Generation ig tracers indexes597 iy = PACK([(k, k=1, SIZE(tr))], MASK=tr(:)%iGeneration==ig) !--- Generation ig tracers indexes 595 598 n = SIZE(iy) 596 599 ix(iq:iq+n-1) = iy !--- Stack growing generations idxs … … 599 602 ELSE 600 603 DO jq = 1, SIZE(tr,DIM=1) !--- Loop on first generation tracers 601 IF(tr(jq)%i gen /= 1) CYCLE!--- Skip generations >= 1604 IF(tr(jq)%iGeneration /= 1) CYCLE !--- Skip generations >= 1 602 605 ix(iq) = jq !--- First generation ancestor index first 603 606 iq = iq + 1 604 iy = strFind(tr(:)% nam1, tr(jq)%name)!--- Indexes of "tr(jq)" childs in "tr(:)"605 ng = MAXVAL(tr(iy)%i gen, MASK=.TRUE., DIM=1)!--- Generations number of the "tr(jq)" family607 iy = strFind(tr(:)%gen0Name, tr(jq)%name) !--- Indexes of "tr(jq)" childs in "tr(:)" 608 ng = MAXVAL(tr(iy)%iGeneration, MASK=.TRUE., DIM=1) !--- Generations number of the "tr(jq)" family 606 609 DO ig = 2, ng !--- Loop on generations for the tr(jq) family 607 iz = find(tr(iy)%i gen, ig, n)!--- Indexes of the tracers "tr(iy(:))" of generation "ig"610 iz = find(tr(iy)%iGeneration, ig, n) !--- Indexes of the tracers "tr(iy(:))" of generation "ig" 608 611 ix(iq:iq+n-1) = iy(iz) !--- Same indexes in "tr(:)" 609 612 iq = iq + n … … 617 620 !============================================================================================================================== 618 621 LOGICAL FUNCTION mergeTracers(sections, tr) RESULT(lerr) 619 TYPE(d b), TARGET,INTENT(IN) :: sections(:)620 TYPE(tra ), ALLOCATABLE, INTENT(OUT) :: tr(:)621 TYPE(tra ), POINTER:: t1(:), t2(:)622 INTEGER, ALLOCATABLE :: ixct(:), ixck(:)622 TYPE(dataBase_type), TARGET, INTENT(IN) :: sections(:) 623 TYPE(trac_type), ALLOCATABLE, INTENT(OUT) :: tr(:) 624 TYPE(trac_type), POINTER :: t1(:), t2(:) 625 INTEGER, ALLOCATABLE :: ixct(:), ixck(:) 623 626 INTEGER :: is, k1, k2, nk2, i1, i2, nt2 624 CHARACTER(LEN=256) :: s1, v1, v2, tnam, knam 627 CHARACTER(LEN=maxlen) :: s1, v1, v2, tnam, knam, modname 628 modname = 'mergeTracers' 625 629 lerr = .FALSE. 626 630 t1 => sections(1)%trac(:) !--- Alias: first tracers section … … 634 638 tr = [tr, PACK(t2, MASK= ixct==0)] !--- Append with new tracers 635 639 IF( ALL(ixct == 0) ) CYCLE !--- No common tracers => done 636 CALL msg('Tracers defined in previous sections and duplicated in "'//TRIM(sections(is)%name)//'":' )637 CALL msg( t1(PACK(ixct, MASK = ixct/=0))%name, nmax=128 )!--- Display duplicates (the 128 first at most)640 CALL msg('Tracers defined in previous sections and duplicated in "'//TRIM(sections(is)%name)//'":', modname) 641 CALL msg(t1(PACK(ixct, MASK = ixct/=0))%name, modname, nmax=128) !--- Display duplicates (the 128 first at most) 638 642 !-------------------------------------------------------------------------------------------------------------------------- 639 643 DO i2=1,nt2; tnam = t2(i2)%name !=== LOOP ON COMMON TRACERS … … 644 648 s1=' of "'//TRIM(tnam)//'" in "'//TRIM(sections(is)%name)//'" not matching previous value' 645 649 646 IF(test(fmsg( t1(i1)%prnt /= t2(i2)%prnt, 'Parent name'//TRIM(s1)),lerr)) RETURN647 IF(test(fmsg( t1(i1)%type /= t2(i2)%type, 'Type' //TRIM(s1)),lerr)) RETURN648 IF(test(fmsg( t1(i1)%igen /= t2(i2)%igen, 'Generation' //TRIM(s1)), lerr)) RETURN650 IF(test(fmsg('Parent name'//TRIM(s1), modname, t1(i1)%parent /= t2(i2)%parent), lerr)) RETURN 651 IF(test(fmsg('Type' //TRIM(s1), modname, t1(i1)%type /= t2(i2)%type), lerr)) RETURN 652 IF(test(fmsg('Generation' //TRIM(s1), modname, t1(i1)%iGeneration /= t2(i2)%iGeneration), lerr)) RETURN 649 653 650 654 !=== APPEND <key>=<val> PAIRS NOT PREVIOULSLY DEFINED … … 657 661 658 662 !--- KEEP TRACK OF THE COMPONENTS NAMES 659 tr(i1)%comp = TRIM(tr(i1)%comp)//','//TRIM(tr(i2)%comp)663 tr(i1)%component = TRIM(tr(i1)%component)//','//TRIM(tr(i2)%component) 660 664 661 665 !--- SELECT COMMON TRACERS WITH DIFFERING KEYS VALUES (PREVIOUS VALUE IS KEPT) … … 667 671 668 672 !--- DISPLAY INFORMATION: OLD VALUES ARE KEPT FOR THE KEYS FOUND IN PREVIOUS AND CURRENT SECTIONS 669 CALL msg('Key(s)'//TRIM(s1) )673 CALL msg('Key(s)'//TRIM(s1), modname) 670 674 DO k2 = 1, nk2 !--- Loop on keys found in both t1(:) and t2(:) 671 675 knam = t2(i2)%keys%key(k2) !--- Name of the current key … … 673 677 IF(k1 == 0) CYCLE !--- New keys are skipped 674 678 v1 = t1(i1)%keys%val(k1); v2 = t2(i2)%keys%val(k2) !--- Key values in t1(:) and t2(:) 675 CALL msg(' * '//TRIM(knam)//'='//TRIM(v2)//' ; previous value kept:'//TRIM(v1) )679 CALL msg(' * '//TRIM(knam)//'='//TRIM(v2)//' ; previous value kept:'//TRIM(v1), modname) 676 680 END DO 677 681 !------------------------------------------------------------------------------------------------------------------------ … … 686 690 !============================================================================================================================== 687 691 LOGICAL FUNCTION cumulTracers(sections, tr) RESULT(lerr) 688 TYPE(d b), TARGET,INTENT(IN) :: sections(:)689 TYPE(tra ), ALLOCATABLE, INTENT(OUT) :: tr(:)690 TYPE(tra ), POINTER :: t1(:), t2(:)692 TYPE(dataBase_type), TARGET, INTENT(IN) :: sections(:) 693 TYPE(trac_type), ALLOCATABLE, INTENT(OUT) :: tr(:) 694 TYPE(trac_type), POINTER :: t1(:), t2(:) 691 695 INTEGER, ALLOCATABLE :: nt(:) 692 CHARACTER(LEN= 256):: tnam, tnam_new696 CHARACTER(LEN=maxlen) :: tnam, tnam_new 693 697 INTEGER :: iq, nq, is, ns, nsec 694 698 lerr = .FALSE. !--- Can't fail ; kept to match "mergeTracer" interface. … … 709 713 ns = nt(is) !--- Number of tracers in the current section 710 714 tr(iq + nq)%name = tnam_new !--- Modify tracer name 711 WHERE(tr(1+nq:ns+nq)%p rnt==tnam) tr(1+nq:ns+nq)%prnt=tnam_new !--- Modify parent name715 WHERE(tr(1+nq:ns+nq)%parent==tnam) tr(1+nq:ns+nq)%parent=tnam_new !--- Modify parent name 712 716 !-------------------------------------------------------------------------------------------------------------------------- 713 717 END DO … … 721 725 !============================================================================================================================== 722 726 SUBROUTINE setDirectKeys(tr) 723 TYPE(tra ), INTENT(INOUT) :: tr(:)724 CALL indexUpdate(tr) !--- Update i parnt and idescindexes vectors727 TYPE(trac_type), INTENT(INOUT) :: tr(:) 728 CALL indexUpdate(tr) !--- Update iqParent and iqDescen indexes vectors 725 729 ! DO iq = 1, SIZE(tr) 726 730 ! tr(iq)%keys%<key> = getKey_prv(it, "<key>", tr%keys, tran0 ) !--- For additional keys … … 730 734 731 735 !============================================================================================================================== 732 LOGICAL FUNCTION dispTraSection(message, sname) RESULT(lerr) 733 CHARACTER(LEN=*), INTENT(IN) :: message 734 CHARACTER(LEN=*), INTENT(IN) :: sname 736 LOGICAL FUNCTION dispTraSection(message, sname, modname) RESULT(lerr) 737 CHARACTER(LEN=*), INTENT(IN) :: message, sname, modname 735 738 INTEGER :: idb, iq, nq 736 739 INTEGER, ALLOCATABLE :: hadv(:), vadv(:) 737 TYPE(tra ), POINTER :: tm(:)740 TYPE(trac_type), POINTER :: tm(:) 738 741 lerr = .FALSE. 739 742 idb = strIdx(dBase(:)%name, sname); IF(idb == 0) RETURN … … 742 745 IF(test(getKeyByName_im('hadv', hadv, tm(:)%name, tm(:)%keys),lerr)) RETURN 743 746 IF(test(getKeyByName_im('vadv', vadv, tm(:)%name, tm(:)%keys),lerr)) RETURN 744 CALL msg(TRIM(message)//':' )747 CALL msg(TRIM(message)//':', modname) 745 748 IF(test(dispTable('iiissis', ['iq ','hadv ','vadv ','short name','parent ','igen ','phase '], & 746 cat(tm(:)%name, tm(:)%prnt, tm(:)%phas), cat([(iq, iq=1, nq)], hadv, vadv, tm(:)%igen)), lerr)) RETURN749 cat(tm(:)%name, tm(:)%parent, tm(:)%phase), cat([(iq, iq=1, nq)], hadv, vadv, tm(:)%iGeneration)), lerr)) RETURN 747 750 END FUNCTION dispTraSection 748 751 !============================================================================================================================== … … 754 757 !============================================================================================================================== 755 758 FUNCTION aliasTracer(tname, t) RESULT(out) 756 TYPE(tra ), POINTER :: out757 CHARACTER(LEN=*), INTENT(IN) :: tname758 TYPE(tra ), TARGET, INTENT(IN) :: t(:)759 TYPE(trac_type), POINTER :: out 760 CHARACTER(LEN=*), INTENT(IN) :: tname 761 TYPE(trac_type), TARGET, INTENT(IN) :: t(:) 759 762 INTEGER :: it 760 763 it = strIdx(t(:)%name, tname) … … 768 771 !============================================================================================================================== 769 772 FUNCTION trSubset_Indx(trac,idx) RESULT(out) 770 TYPE(tra ), ALLOCATABLE :: out(:)771 TYPE(tra ), ALLOCATABLE, INTENT(IN) :: trac(:)772 INTEGER, INTENT(IN) :: idx(:)773 TYPE(trac_type), ALLOCATABLE :: out(:) 774 TYPE(trac_type), ALLOCATABLE, INTENT(IN) :: trac(:) 775 INTEGER, INTENT(IN) :: idx(:) 773 776 out = trac(idx) 774 777 CALL indexUpdate(out) … … 776 779 !------------------------------------------------------------------------------------------------------------------------------ 777 780 FUNCTION trSubset_Name(trac,nam) RESULT(out) 778 TYPE(tra ), ALLOCATABLE :: out(:)779 TYPE(tra ), ALLOCATABLE, INTENT(IN) :: trac(:)780 CHARACTER(LEN=*), INTENT(IN) :: nam(:)781 TYPE(trac_type), ALLOCATABLE :: out(:) 782 TYPE(trac_type), ALLOCATABLE, INTENT(IN) :: trac(:) 783 CHARACTER(LEN=*), INTENT(IN) :: nam(:) 781 784 out = trac(strIdx(trac(:)%name, nam)) 782 785 CALL indexUpdate(out) … … 788 791 !=== CREATE THE SUBSET OF THE TRACERS DESCRIPTORS LIST "trac" HAVING THE FIRST GENERATION ANCESTOR NAMED "nam" ================ 789 792 !============================================================================================================================== 790 FUNCTION trSubset_ Nam1(trac,nam) RESULT(out)791 TYPE(tra ), ALLOCATABLE :: out(:)792 TYPE(tra ), ALLOCATABLE, INTENT(IN) :: trac(:)793 CHARACTER(LEN=*), INTENT(IN) :: nam794 out = trac(strFind(delPhase(trac(:)% nam1), nam))793 FUNCTION trSubset_gen0Name(trac,nam) RESULT(out) 794 TYPE(trac_type), ALLOCATABLE :: out(:) 795 TYPE(trac_type), ALLOCATABLE, INTENT(IN) :: trac(:) 796 CHARACTER(LEN=*), INTENT(IN) :: nam 797 out = trac(strFind(delPhase(trac(:)%gen0Name), nam)) 795 798 CALL indexUpdate(out) 796 END FUNCTION trSubset_ Nam1797 !------------------------------------------------------------------------------------------------------------------------------ 798 799 800 !============================================================================================================================== 801 !=== UPDATE THE INDEXES i parnt(:), idesc=(:) AND igen(:) IN THE TRACERS DESCRIPTOR LIST "tr" (USEFULL FOR SUBSETS) ============799 END FUNCTION trSubset_gen0Name 800 !------------------------------------------------------------------------------------------------------------------------------ 801 802 803 !============================================================================================================================== 804 !=== UPDATE THE INDEXES iqParent, iqDescend AND iGeneration IN THE TRACERS DESCRIPTOR LIST "tr" (USEFULL FOR SUBSETS) ========= 802 805 !============================================================================================================================== 803 806 SUBROUTINE indexUpdate(tr) 804 TYPE(tra ), INTENT(INOUT) :: tr(:)807 TYPE(trac_type), INTENT(INOUT) :: tr(:) 805 808 INTEGER :: iq, ig, ng, ngen 806 809 INTEGER, ALLOCATABLE :: ix(:) 807 tr(:)%i prnt = strIdx( tr(:)%name, tr(:)%prnt )!--- Parent index808 ngen = MAXVAL(tr(:)%i gen, MASK=.TRUE.)810 tr(:)%iqParent = strIdx( tr(:)%name, tr(:)%parent ) !--- Parent index 811 ngen = MAXVAL(tr(:)%iGeneration, MASK=.TRUE.) 809 812 DO iq = 1, SIZE(tr) 810 ng = tr(iq)%i gen!--- Generation of the current tracer813 ng = tr(iq)%iGeneration !--- Generation of the current tracer 811 814 ix = idxAncestor(tr, igen = ng); ix = PACK(ix, ix/=0) !--- Indexes of the tracers with ancestor tr(iq) 812 815 !--- Childs indexes in growing generation order 813 tr(iq)%i desc = [( PACK(ix, MASK = tr(ix)%igen == ig), ig = ng+1, ngen)]814 tr(iq)%n desc = SUM( [( COUNT(tr(ix)%igen == ig), ig = ng+1, ngen)] )815 tr(iq)%n chld = COUNT(tr(ix)%igen == ng+1)816 tr(iq)%iqDescen = [( PACK(ix, MASK = tr(ix)%iGeneration == ig), ig = ng+1, ngen)] 817 tr(iq)%nqDescen = SUM( [( COUNT(tr(ix)%iGeneration == ig), ig = ng+1, ngen)] ) 818 tr(iq)%nqChilds = COUNT(tr(ix)%iGeneration == ng+1) 816 819 END DO 817 820 END SUBROUTINE indexUpdate … … 820 823 821 824 !============================================================================================================================== 822 !=== READ FILE "fnam" TO APPEND THE "dBase" TRACERS DATABASE WITH AS MUCH SECTIONS AS PARENTS NAMES IN "isot(:)%p rnt":====823 !=== * Each section dBase(i)%name contains the isotopes "dBase(i)%trac(:)" descending on "dBase(i)%name"="iso(i)%p rnt"====825 !=== READ FILE "fnam" TO APPEND THE "dBase" TRACERS DATABASE WITH AS MUCH SECTIONS AS PARENTS NAMES IN "isot(:)%parent": ==== 826 !=== * Each section dBase(i)%name contains the isotopes "dBase(i)%trac(:)" descending on "dBase(i)%name"="iso(i)%parent" ==== 824 827 !=== * For each isotopes class, the <key>=<val> vector of each tracer is moved into the isotopes descriptor "isot" ==== 825 828 !=== NOTES: ==== … … 833 836 !============================================================================================================================== 834 837 LOGICAL FUNCTION readIsotopesFile(fnam, isot) RESULT(lerr) 835 CHARACTER(LEN=*), INTENT(IN) :: fnam!--- Input file name836 TYPE(iso ), TARGET, INTENT(INOUT) :: isot(:)!--- Isotopes descriptors (field "prnt" must be defined !)838 CHARACTER(LEN=*), INTENT(IN) :: fnam !--- Input file name 839 TYPE(isot_type), TARGET, INTENT(INOUT) :: isot(:) !--- Isotopes descriptors (field "prnt" must be defined !) 837 840 INTEGER :: ik, is, it, idb, nk0, i, iis 838 841 INTEGER :: nk, ns, nt, ndb, nb0, i0 839 CHARACTER(LEN=256), POINTER :: k(:), v(:), k0(:), v0(:) 840 CHARACTER(LEN=256), ALLOCATABLE :: vals(:) 841 CHARACTER(LEN=256) :: val 842 TYPE(kys), POINTER :: ky(:) 843 TYPE(tra), POINTER :: tt(:), t 844 TYPE(db), ALLOCATABLE :: tdb(:) 845 LOGICAL, ALLOCATABLE :: liso(:) 842 CHARACTER(LEN=maxlen), POINTER :: k(:), v(:), k0(:), v0(:) 843 CHARACTER(LEN=maxlen), ALLOCATABLE :: vals(:) 844 CHARACTER(LEN=maxlen) :: val, modname 845 TYPE(keys_type), POINTER :: ky(:) 846 TYPE(trac_type), POINTER :: tt(:), t 847 TYPE(dataBase_type), ALLOCATABLE :: tdb(:) 848 LOGICAL, ALLOCATABLE :: liso(:) 849 modname = 'readIsotopesFile' 846 850 847 851 !--- THE INPUT FILE MUST BE PRESENT 848 IF(test(fmsg( testFile(fnam),'Missing isotopes parameters file "'//TRIM(fnam)//'"'),lerr)) RETURN852 IF(test(fmsg('Missing isotopes parameters file "'//TRIM(fnam)//'"', modname, testFile(fnam)),lerr)) RETURN 849 853 850 854 !--- READ THE FILE SECTIONS, ONE EACH PARENT TRACER 851 855 nb0 = SIZE(dBase, DIM=1)+1 !--- Next database element index 852 IF(test(readSections(fnam,strStack(isot(:)%p rnt,',')),lerr)) RETURN!--- Read sections, one each parent tracer856 IF(test(readSections(fnam,strStack(isot(:)%parent,',')),lerr)) RETURN !--- Read sections, one each parent tracer 853 857 ndb = SIZE(dBase, DIM=1) !--- Current database size 854 858 DO idb = nb0, ndb … … 886 890 ALLOCATE(tdb(nb0-1)); tdb(1:nb0-1)=dBase(1:nb0-1); CALL MOVE_ALLOC(FROM=tdb, TO=dBase) 887 891 END IF 888 lerr = dispIsotopes(isot, 'Isotopes parameters read from file' )892 lerr = dispIsotopes(isot, 'Isotopes parameters read from file', modname) 889 893 890 894 END FUNCTION readIsotopesFile … … 899 903 !============================================================================================================================== 900 904 SUBROUTINE initIsotopes(trac, isot) 901 TYPE(tra ), ALLOCATABLE, TARGET, INTENT(INOUT) :: trac(:)902 TYPE(iso ), ALLOCATABLE, TARGET, INTENT(INOUT) :: isot(:)903 CHARACTER(LEN= 256), ALLOCATABLE :: p(:), str(:)!--- Temporary storage904 CHARACTER(LEN= 256) :: iname905 TYPE(trac_type), ALLOCATABLE, TARGET, INTENT(INOUT) :: trac(:) 906 TYPE(isot_type), ALLOCATABLE, TARGET, INTENT(INOUT) :: isot(:) 907 CHARACTER(LEN=maxlen), ALLOCATABLE :: p(:), str(:) !--- Temporary storage 908 CHARACTER(LEN=maxlen) :: iname 905 909 CHARACTER(LEN=1) :: ph !--- Phase 906 910 INTEGER :: nbIso, ic, ip, iq, it, iz 907 911 LOGICAL, ALLOCATABLE :: ll(:) !--- Mask 908 TYPE(tra ), POINTER :: t(:), t1909 TYPE(iso ), POINTER :: s912 TYPE(trac_type), POINTER :: t(:), t1 913 TYPE(isot_type), POINTER :: s 910 914 911 915 t => trac 912 916 913 p = PACK(delPhase(t%p rnt), MASK = t%type=='tracer' .AND. t%igen==2)!--- Parents of 2nd generation isotopes917 p = PACK(delPhase(t%parent), MASK = t%type=='tracer' .AND. t%iGeneration==2) !--- Parents of 2nd generation isotopes 914 918 CALL strReduce(p, nbIso) 915 919 ALLOCATE(isot(nbIso)) … … 918 922 919 923 !--- ISOTOPES RELATED VARIABLES ; NULL OR EMPTY IF NO ISOTOPES 920 isot(:)%p rnt = p924 isot(:)%parent = p 921 925 DO ic = 1, SIZE(p) !--- Loop on isotopes classes 922 926 s => isot(ic) 923 iname = s%p rnt!--- Current isotopes class name (parent tracer name)927 iname = s%parent !--- Current isotopes class name (parent tracer name) 924 928 925 929 !=== Isotopes childs of tracer "iname": mask, names, number (same for each phase of "iname") 926 ll = t(:)%type=='tracer' .AND. delPhase(t(:)%p rnt) == iname .AND. t(:)%phas== 'g'930 ll = t(:)%type=='tracer' .AND. delPhase(t(:)%parent) == iname .AND. t(:)%phase == 'g' 927 931 str = PACK(delPhase(t(:)%name), MASK = ll) !--- Effectively found isotopes of "iname" 928 932 s%niso = SIZE(str) !--- Number of "effectively found isotopes of "iname" … … 931 935 932 936 !=== Geographic tagging tracers descending on tracer "iname": mask, names, number 933 ll = t(:)%type=='tag' .AND. delPhase(t(:)% nam1) == iname .AND. t(:)%igen == 3937 ll = t(:)%type=='tag' .AND. delPhase(t(:)%gen0Name) == iname .AND. t(:)%iGeneration == 3 934 938 s%zone = PACK(strTail(t(:)%name,'_',lFirst=.TRUE.), MASK = ll) !--- Tagging zones names for isotopes category "iname" 935 939 CALL strReduce(s%zone) … … 946 950 947 951 !=== Phases for tracer "iname" 948 s%phas = ''949 DO ip = 1, nphases; ph = known_phases(ip:ip); IF(strIdx(t%name,addPhase(iname, ph)) /= 0) s%phas = TRIM(s%phas)//ph; END DO950 s%npha = LEN_TRIM(s%phas ) !--- Equal to "nqo" for water952 s%phase = '' 953 DO ip = 1, nphases; ph = known_phases(ip:ip); IF(strIdx(t%name,addPhase(iname, ph)) /= 0) s%phase = TRIM(s%phase)//ph; END DO 954 s%npha = LEN_TRIM(s%phase) !--- Equal to "nqo" for water 951 955 952 956 !=== Tables giving the index in a table of effectively found items for each dynamical tracer (1<=iq<=nqtot) 953 957 DO iq = 1, SIZE(t) 954 958 t1 => trac(iq) 955 IF(delPhase(t1% nam1) /= iname) CYCLE!--- Only deal with tracers descending on "iname"956 t1%iso_i gr = ic !--- Isotopes family idx in list "isotopes(:)%prnt"957 t1%iso_ num = strIdx(s%trac, delPhase(strHead(t1%name,'_')))!--- Current isotope idx in effective isotopes list958 t1%iso_ zon = strIdx(s%zone, strTail(t1%name,'_') )!--- Current isotope zone idx in effective zones list959 t1%iso_ pha = INDEX(s%phas,TRIM(t1%phas))!--- Current isotope phase idx in effective phases list960 IF(t1%i gen /= 3) t1%iso_zon = 0!--- Skip possible generation 2 tagging tracers959 IF(delPhase(t1%gen0Name) /= iname) CYCLE !--- Only deal with tracers descending on "iname" 960 t1%iso_iGroup = ic !--- Isotopes family idx in list "isotopes(:)%parent" 961 t1%iso_iName = strIdx(s%trac, delPhase(strHead(t1%name,'_'))) !--- Current isotope idx in effective isotopes list 962 t1%iso_iZone = strIdx(s%zone, strTail(t1%name,'_') ) !--- Current isotope zone idx in effective zones list 963 t1%iso_iPhase = INDEX(s%phase,TRIM(t1%phase)) !--- Current isotope phase idx in effective phases list 964 IF(t1%iGeneration /= 3) t1%iso_iZone = 0 !--- Skip possible generation 2 tagging tracers 961 965 END DO 962 966 963 967 !=== Table used to get iq (index in dyn array, size nqtot) from the isotope and phase indexes ; the full isotopes list 964 968 ! (including tagging tracers) is sorted this way: iso1, iso2, ..., iso1_zone1, iso2_zone1, ..., iso1_zoneN, iso2_zoneN 965 s%iTraPha = RESHAPE( [( (strIdx(t(:)%name, addPhase(s%trac(it),s%phas (ip:ip))),it=1, s%nitr), ip=1, s%npha)], &969 s%iTraPha = RESHAPE( [( (strIdx(t(:)%name, addPhase(s%trac(it),s%phase(ip:ip))), it=1, s%nitr), ip=1, s%npha)], & 966 970 [s%nitr, s%npha] ) 967 971 … … 970 974 [s%nzon, s%niso] ) 971 975 END DO 972 973 !=== Indexes, in dynamical tracers list, of the tracers transmitted to phytrac (nqtottr non-vanishing elements)974 ll = delPhase(t%name)/='H2O' .AND. t%iso_num ==0 !--- Mask of tracers passed to the physics975 t(:)%itr = UNPACK([(iq,iq=1,COUNT(ll))], ll, [(0, iq=1, SIZE(t))])976 976 977 977 !=== READ PHYSICAL PARAMETERS FROM "isotopes_params.def" FILE … … 984 984 985 985 !============================================================================================================================== 986 LOGICAL FUNCTION dispIsotopes(ides, message ) RESULT(lerr)987 TYPE(iso ),INTENT(IN) :: ides(:) !--- Isotopes descriptor vector986 LOGICAL FUNCTION dispIsotopes(ides, message, modname) RESULT(lerr) 987 TYPE(isot_type), INTENT(IN) :: ides(:) !--- Isotopes descriptor vector 988 988 CHARACTER(LEN=*), INTENT(IN) :: message !--- Message to display 989 CHARACTER(LEN=*), INTENT(IN) :: modname !--- Calling subroutine name 989 990 INTEGER :: ik, nk, ip, it, nt 990 CHARACTER(LEN= 256) :: prf991 CHARACTER(LEN= 256), ALLOCATABLE :: ttl(:), val(:,:)992 CALL msg(TRIM(message)//':' )991 CHARACTER(LEN=maxlen) :: prf 992 CHARACTER(LEN=maxlen), ALLOCATABLE :: ttl(:), val(:,:) 993 CALL msg(TRIM(message)//':', modname) 993 994 DO ip = 1, SIZE(ides) !--- Loop on parents tracers 994 995 nk = SIZE(ides(ip)%keys(1)%key) !--- Same keys for each isotope … … 1003 1004 END DO 1004 1005 END DO 1005 IF(test(fmsg(dispTable(prf, ttl, val, cat([(it,it=1,nt)]), rFmt='(EN8.4)'),'Problem with the table content'), lerr)) RETURN 1006 IF(test(fmsg('Problem with the table content', modname, dispTable(prf, ttl, val, cat([(it,it=1,nt)]), rFmt='(EN8.4)')), & 1007 lerr)) RETURN 1006 1008 DEALLOCATE(ttl, val) 1007 1009 END DO … … 1016 1018 !------------------------------------------------------------------------------------------------------------------------------ 1017 1019 CHARACTER(LEN=*), INTENT(IN) :: key, val 1018 TYPE(k ys),INTENT(INOUT) :: ky1020 TYPE(keys_type), INTENT(INOUT) :: ky 1019 1021 LOGICAL, OPTIONAL, INTENT(IN) :: lOverWrite 1020 CHARACTER(LEN= 256),ALLOCATABLE :: k(:), v(:)1022 CHARACTER(LEN=maxlen), ALLOCATABLE :: k(:), v(:) 1021 1023 INTEGER :: iky, nky 1022 1024 LOGICAL :: lo … … 1037 1039 !------------------------------------------------------------------------------------------------------------------------------ 1038 1040 CHARACTER(LEN=*), INTENT(IN) :: key, val 1039 TYPE(k ys),INTENT(INOUT) :: ky(:)1041 TYPE(keys_type), INTENT(INOUT) :: ky(:) 1040 1042 LOGICAL, OPTIONAL, INTENT(IN) :: lOverWrite 1041 1043 INTEGER :: itr … … 1050 1052 ! Purpose: The values of the keys of the tracer named "tr0" are overwritten by the values found in the *.def files, if any. 1051 1053 !------------------------------------------------------------------------------------------------------------------------------ 1052 TYPE(tra ), ALLOCATABLE, INTENT(INOUT) :: t(:)1053 CHARACTER(LEN=*), INTENT(IN) :: tr01054 CHARACTER(LEN= 256) :: val1055 INTEGER :: ik, jd1054 TYPE(trac_type), ALLOCATABLE, INTENT(INOUT) :: t(:) 1055 CHARACTER(LEN=*), INTENT(IN) :: tr0 1056 CHARACTER(LEN=maxlen) :: val 1057 INTEGER :: ik, jd 1056 1058 jd = strIdx(t%name, tr0) 1057 1059 IF(jd == 0) RETURN … … 1069 1071 INTEGER, INTENT(IN) :: itr 1070 1072 CHARACTER(LEN=*), INTENT(IN) :: keyn(:) 1071 TYPE(tra ),INTENT(INOUT) :: ky(:)1072 CHARACTER(LEN= 256), ALLOCATABLE :: k(:), v(:)1073 LOGICAL, ALLOCATABLE :: ll(:)1073 TYPE(trac_type), INTENT(INOUT) :: ky(:) 1074 CHARACTER(LEN=maxlen), ALLOCATABLE :: k(:), v(:) 1075 LOGICAL, ALLOCATABLE :: ll(:) 1074 1076 INTEGER :: iky 1075 1077 !------------------------------------------------------------------------------------------------------------------------------ … … 1086 1088 !------------------------------------------------------------------------------------------------------------------------------ 1087 1089 CHARACTER(LEN=*), INTENT(IN) :: keyn(:) 1088 TYPE(tra ),INTENT(INOUT) :: ky(:)1090 TYPE(trac_type), INTENT(INOUT) :: ky(:) 1089 1091 INTEGER :: iky 1090 1092 !------------------------------------------------------------------------------------------------------------------------------ … … 1100 1102 !============================================================================================================================== 1101 1103 SUBROUTINE getKey_init(tracers_, isotopes_) 1102 TYPE(tra ), OPTIONAL, INTENT(IN) :: tracers_(:)1103 TYPE(iso ), OPTIONAL, INTENT(IN) :: isotopes_(:)1104 TYPE(trac_type), OPTIONAL, INTENT(IN) :: tracers_(:) 1105 TYPE(isot_type), OPTIONAL, INTENT(IN) :: isotopes_(:) 1104 1106 IF(PRESENT( tracers_)) tracers = tracers_ 1105 1107 IF(PRESENT(isotopes_)) isotopes = isotopes_ 1106 1108 END SUBROUTINE getKey_init 1107 1109 !============================================================================================================================== 1108 CHARACTER(LEN= 256) FUNCTION fgetKey(itr, keyn, ky, def_val) RESULT(out)1110 CHARACTER(LEN=maxlen) FUNCTION fgetKey(itr, keyn, ky, def_val) RESULT(out) 1109 1111 !------------------------------------------------------------------------------------------------------------------------------ 1110 1112 ! Purpose: Internal function ; get a key value in string format (this is the returned argument). … … 1112 1114 INTEGER, INTENT(IN) :: itr 1113 1115 CHARACTER(LEN=*), INTENT(IN) :: keyn 1114 TYPE(k ys),INTENT(IN) :: ky(:)1116 TYPE(keys_type), INTENT(IN) :: ky(:) 1115 1117 CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: def_val 1116 1118 !------------------------------------------------------------------------------------------------------------------------------ … … 1126 1128 ! * "ky" specified: try in "ky" for "tnam" with phase and tagging suffixes, then without. 1127 1129 ! The returned error code is always .FALSE.: an empty string is returned when the key hasn't been found. 1128 CHARACTER(LEN=*), INTENT(IN) :: keyn1129 CHARACTER(LEN= 256),INTENT(OUT) :: val1130 CHARACTER(LEN=*), INTENT(IN) :: tname1131 TYPE(k ys), OPTIONAL, INTENT(IN) :: ky(:)1130 CHARACTER(LEN=*), INTENT(IN) :: keyn 1131 CHARACTER(LEN=maxlen), INTENT(OUT) :: val 1132 CHARACTER(LEN=*), INTENT(IN) :: tname 1133 TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) 1132 1134 INTEGER :: is 1133 1135 lerr = .FALSE. … … 1147 1149 1148 1150 FUNCTION getKeyByName_prv(keyn, tname, ky) RESULT(val) 1149 CHARACTER(LEN= 256):: val1151 CHARACTER(LEN=maxlen) :: val 1150 1152 CHARACTER(LEN=*), INTENT(IN) :: keyn 1151 1153 CHARACTER(LEN=*), INTENT(IN) :: tname 1152 TYPE(k ys),INTENT(IN) :: ky(:)1154 TYPE(keys_type), INTENT(IN) :: ky(:) 1153 1155 INTEGER :: itr, iky 1154 1156 val = ''; iky = 0 … … 1162 1164 LOGICAL FUNCTION getKeyByName_sm(keyn, val, tnam, ky) RESULT(lerr) 1163 1165 CHARACTER(LEN=*), INTENT(IN) :: keyn 1164 CHARACTER(LEN= 256),ALLOCATABLE, INTENT(OUT) :: val(:)1166 CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: val(:) 1165 1167 CHARACTER(LEN=*), TARGET, OPTIONAL, INTENT(IN) :: tnam(:) 1166 TYPE(k ys),TARGET, OPTIONAL, INTENT(IN) :: ky(:)1167 CHARACTER(LEN= 256),POINTER :: n(:)1168 TYPE(keys_type), TARGET, OPTIONAL, INTENT(IN) :: ky(:) 1169 CHARACTER(LEN=maxlen), POINTER :: n(:) 1168 1170 INTEGER :: iq 1169 1171 n => tracers(:)%keys%name; IF(PRESENT(tnam)) n => tnam(:) … … 1174 1176 !============================================================================================================================== 1175 1177 LOGICAL FUNCTION getKeyByName_i1(keyn, val, tnam, ky) RESULT(lerr) 1176 CHARACTER(LEN=*), INTENT(IN) :: keyn1177 INTEGER, INTENT(OUT) :: val1178 CHARACTER(LEN=*), INTENT(IN) :: tnam1179 TYPE(k ys), OPTIONAL, INTENT(IN) :: ky(:)1180 CHARACTER(LEN= 256) :: sval1178 CHARACTER(LEN=*), INTENT(IN) :: keyn 1179 INTEGER, INTENT(OUT) :: val 1180 CHARACTER(LEN=*), INTENT(IN) :: tnam 1181 TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) 1182 CHARACTER(LEN=maxlen) :: sval 1181 1183 INTEGER :: ierr 1182 1184 IF( PRESENT(ky)) lerr = getKeyByName_s1(keyn, sval, tnam, ky) 1183 1185 IF(.NOT.PRESENT(ky)) lerr = getKeyByName_s1(keyn, sval, tnam) 1184 IF(test(fmsg( lerr, 'key "'//TRIM(keyn)//'" or tracer "'//TRIM(tnam)//'" is missing'),lerr)) RETURN1186 IF(test(fmsg('key "'//TRIM(keyn)//'" or tracer "'//TRIM(tnam)//'" is missing', modname, lerr), lerr)) RETURN 1185 1187 READ(sval, *, IOSTAT=ierr) val 1186 IF(test(fmsg( ierr/=0,'key "'//TRIM(keyn)//'" of tracer "'//TRIM(tnam)//'" is not an integer'), lerr)) RETURN1188 IF(test(fmsg('key "'//TRIM(keyn)//'" of tracer "'//TRIM(tnam)//'" is not an integer', modname, lerr), lerr)) RETURN 1187 1189 END FUNCTION getKeyByName_i1 1188 1190 !============================================================================================================================== … … 1191 1193 INTEGER, ALLOCATABLE, INTENT(OUT) :: val(:) 1192 1194 CHARACTER(LEN=*), TARGET, OPTIONAL, INTENT(IN) :: tnam(:) 1193 TYPE(k ys),TARGET, OPTIONAL, INTENT(IN) :: ky(:)1194 CHARACTER(LEN= 256), POINTER :: n(:)1195 TYPE(keys_type), TARGET, OPTIONAL, INTENT(IN) :: ky(:) 1196 CHARACTER(LEN=maxlen), POINTER :: n(:) 1195 1197 INTEGER :: iq 1196 1198 n => tracers(:)%name; IF(PRESENT(tnam)) n => tnam(:) … … 1201 1203 !============================================================================================================================== 1202 1204 LOGICAL FUNCTION getKeyByName_r1(keyn, val, tnam, ky) RESULT(lerr) 1203 CHARACTER(LEN=*), INTENT(IN) :: keyn1204 REAL, INTENT(OUT) :: val1205 CHARACTER(LEN=*), INTENT(IN) :: tnam1206 TYPE(k ys), OPTIONAL, INTENT(IN) :: ky(:)1207 CHARACTER(LEN= 256) :: sval1205 CHARACTER(LEN=*), INTENT(IN) :: keyn 1206 REAL, INTENT(OUT) :: val 1207 CHARACTER(LEN=*), INTENT(IN) :: tnam 1208 TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) 1209 CHARACTER(LEN=maxlen) :: sval 1208 1210 INTEGER :: ierr 1209 1211 IF( PRESENT(ky)) lerr = getKeyByName_s1(keyn, sval, tnam, ky) 1210 1212 IF(.NOT.PRESENT(ky)) lerr = getKeyByName_s1(keyn, sval, tnam) 1211 IF(test(fmsg( lerr, 'key "'//TRIM(keyn)//'" or tracer "'//TRIM(tnam)//'" is missing'),lerr)) RETURN1213 IF(test(fmsg('key "'//TRIM(keyn)//'" or tracer "'//TRIM(tnam)//'" is missing', modname, lerr), lerr)) RETURN 1212 1214 READ(sval, *, IOSTAT=ierr) val 1213 IF(test(fmsg( ierr/=0,'key "'//TRIM(keyn)//'" of tracer "'//TRIM(tnam)//'" is not a real'), lerr)) RETURN1215 IF(test(fmsg('key "'//TRIM(keyn)//'" of tracer "'//TRIM(tnam)//'" is not a real', modname, lerr), lerr)) RETURN 1214 1216 END FUNCTION getKeyByName_r1 1215 1217 !============================================================================================================================== … … 1218 1220 REAL, ALLOCATABLE, INTENT(OUT) :: val(:) 1219 1221 CHARACTER(LEN=*), TARGET, OPTIONAL, INTENT(IN) :: tnam(:) 1220 TYPE(k ys),TARGET, OPTIONAL, INTENT(IN) :: ky(:)1221 CHARACTER(LEN= 256), POINTER :: n(:)1222 TYPE(keys_type), TARGET, OPTIONAL, INTENT(IN) :: ky(:) 1223 CHARACTER(LEN=maxlen), POINTER :: n(:) 1222 1224 INTEGER :: iq 1223 1225 n => tracers(:)%name; IF(PRESENT(tnam)) n => tnam(:) … … 1232 1234 !=== REMOVE, IF ANY, OR ADD THE PHASE SUFFIX OF THE TRACER NAMED "s" ========================================================== 1233 1235 !============================================================================================================================== 1234 ELEMENTAL CHARACTER(LEN= 256) FUNCTION delPhase(s) RESULT(out)1236 ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION delPhase(s) RESULT(out) 1235 1237 CHARACTER(LEN=*), INTENT(IN) :: s 1236 1238 INTEGER :: l, i, ix … … 1249 1251 END FUNCTION delPhase 1250 1252 !------------------------------------------------------------------------------------------------------------------------------ 1251 CHARACTER(LEN= 256) FUNCTION addPhase_1(s,pha) RESULT(out)1253 CHARACTER(LEN=maxlen) FUNCTION addPhase_1(s,pha) RESULT(out) 1252 1254 CHARACTER(LEN=*), INTENT(IN) :: s 1253 1255 CHARACTER(LEN=1), INTENT(IN) :: pha … … 1262 1264 !------------------------------------------------------------------------------------------------------------------------------ 1263 1265 FUNCTION addPhase_m(s,pha) RESULT(out) 1264 CHARACTER(LEN=*), INTENT(IN):: s(:)1265 CHARACTER(LEN=1), INTENT(IN):: pha1266 CHARACTER(LEN= 256), ALLOCATABLE :: out(:)1266 CHARACTER(LEN=*), INTENT(IN) :: s(:) 1267 CHARACTER(LEN=1), INTENT(IN) :: pha 1268 CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:) 1267 1269 INTEGER :: k 1268 1270 out = [( addPhase_1(s(k), pha), k=1, SIZE(s) )] … … 1274 1276 !=== GET THE NAME(S) OF THE ANCESTOR(S) OF TRACER(S) "tname" AT GENERATION "igen" IN THE TRACERS DESCRIPTORS LIST "tr" ======= 1275 1277 !============================================================================================================================== 1276 CHARACTER(LEN= 256) FUNCTION ancestor_1(t, tname, igen) RESULT(out)1277 TYPE(tra ),INTENT(IN) :: t(:)1278 CHARACTER(LEN=maxlen) FUNCTION ancestor_1(t, tname, igen) RESULT(out) 1279 TYPE(trac_type), INTENT(IN) :: t(:) 1278 1280 CHARACTER(LEN=*), INTENT(IN) :: tname 1279 1281 INTEGER, OPTIONAL, INTENT(IN) :: igen … … 1285 1287 !------------------------------------------------------------------------------------------------------------------------------ 1286 1288 FUNCTION ancestor_m(t, tname, igen) RESULT(out) 1287 CHARACTER(LEN= 256), ALLOCATABLE:: out(:)1288 TYPE(tra ),INTENT(IN) :: t(:)1289 CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:) 1290 TYPE(trac_type), INTENT(IN) :: t(:) 1289 1291 CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: tname(:) 1290 1292 INTEGER, OPTIONAL, INTENT(IN) :: igen … … 1305 1307 INTEGER FUNCTION idxAncestor_1(t, tname, igen) RESULT(out) 1306 1308 ! Return the name of the generation "igen" ancestor of "tname" 1307 TYPE(tra ),INTENT(IN) :: t(:)1309 TYPE(trac_type), INTENT(IN) :: t(:) 1308 1310 CHARACTER(LEN=*), INTENT(IN) :: tname 1309 1311 INTEGER, OPTIONAL, INTENT(IN) :: igen … … 1312 1314 out = strIdx(t(:)%name, tname) 1313 1315 IF(out == 0) RETURN 1314 IF(t(out)%i gen <= ig) RETURN1315 DO WHILE(t(out)%i gen > ig); out = strIdx(t(:)%name, t(out)%prnt); END DO1316 IF(t(out)%iGeneration <= ig) RETURN 1317 DO WHILE(t(out)%iGeneration > ig); out = strIdx(t(:)%name, t(out)%parent); END DO 1316 1318 END FUNCTION idxAncestor_1 1317 1319 !------------------------------------------------------------------------------------------------------------------------------ 1318 1320 FUNCTION idxAncestor_m(t, tname, igen) RESULT(out) 1319 1321 INTEGER, ALLOCATABLE :: out(:) 1320 TYPE(tra ),INTENT(IN) :: t(:)1322 TYPE(trac_type), INTENT(IN) :: t(:) 1321 1323 CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: tname(:) 1322 1324 INTEGER, OPTIONAL, INTENT(IN) :: igen
Note: See TracChangeset
for help on using the changeset viewer.