Changeset 5183 for LMDZ6/trunk/libf/misc
- Timestamp:
- Sep 10, 2024, 5:14:23 PM (5 months ago)
- Location:
- LMDZ6/trunk/libf/misc
- Files:
-
- 1 added
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
LMDZ6/trunk/libf/misc/readTracFiles_mod.f90
r5005 r5183 10 10 11 11 PUBLIC :: maxlen !--- PARAMETER FOR CASUAL STRING LENGTH 12 PUBLIC :: trac_type, tracers, setGeneration, indexUpdate !--- TRACERS DESCRIPTION DATABASE + ASSOCIATED TOOLS12 PUBLIC :: keys_type, tracers, setGeneration, indexUpdate !--- TRACERS DESCRIPTION DATABASE + ASSOCIATED TOOLS 13 13 PUBLIC :: testTracersFiles, readTracersFiles !--- TRACERS FILES READING ROUTINES 14 14 PUBLIC :: getKeysDBase, setKeysDBase !--- TOOLS TO GET/SET THE DATABASE (tracers & isotopes) 15 15 PUBLIC :: addTracer, delTracer !--- ADD/REMOVE A TRACER FROM 16 PUBLIC :: addKey, delKey, getKey , keys_type!--- TOOLS TO SET/DEL/GET KEYS FROM/TO tracers & isotopes16 PUBLIC :: addKey, delKey, getKey !--- TOOLS TO SET/DEL/GET KEYS FROM/TO tracers & isotopes 17 17 PUBLIC :: addPhase, delPhase, getPhase, getiPhase, & !--- FUNCTIONS RELATED TO THE PHASES 18 18 nphases, old_phases, phases_sep, known_phases, phases_names !--- + ASSOCIATED VARIABLES … … 35 35 PUBLIC :: itZonIso !--- Idx IN isoName(1:niso) = f(tagging idx, isotope idx) 36 36 PUBLIC :: iqIsoPha !--- Idx IN qx(1:nqtot) = f(isotope idx, phase idx) 37 PUBLIC :: iqWIsoPha !--- Idx IN qx(1:nqtot) = f(isotope idx, phase idx) but with normal water first37 PUBLIC :: iqWIsoPha !--- SAME AS iqIsoPha BUT ISOTOPES LIST STARTS WITH PARENT TRAC 38 38 PUBLIC :: isoCheck !--- FLAG TO RUN ISOTOPES CHECKING ROUTINES 39 39 … … 41 41 !------------------------------------------------------------------------------------------------------------------------------ 42 42 TYPE :: keys_type !=== TYPE FOR A SET OF KEYS ASSOCIATED TO AN ELEMENT 43 CHARACTER(LEN=maxlen) :: name !--- Tracer name44 43 CHARACTER(LEN=maxlen), ALLOCATABLE :: key(:) !--- Keys string list 45 44 CHARACTER(LEN=maxlen), ALLOCATABLE :: val(:) !--- Corresponding values string list 46 45 END TYPE keys_type 47 46 !------------------------------------------------------------------------------------------------------------------------------ 48 TYPE :: trac_type !=== TYPE FOR A SINGLE TRACER NAMED "name" 49 CHARACTER(LEN=maxlen) :: name = '' !--- Name of the tracer 50 TYPE(keys_type) :: keys !--- <key>=<val> pairs vector 51 CHARACTER(LEN=maxlen) :: gen0Name = '' !--- First generation ancestor name 52 CHARACTER(LEN=maxlen) :: parent = '' !--- Parent name 53 CHARACTER(LEN=maxlen) :: longName = '' !--- Long name (with advection scheme suffix) 54 CHARACTER(LEN=maxlen) :: type = 'tracer' !--- Type (so far: 'tracer' / 'tag') 55 CHARACTER(LEN=maxlen) :: phase = 'g' !--- Phase ('g'as / 'l'iquid / 's'olid) 56 CHARACTER(LEN=maxlen) :: component = '' !--- Coma-separated list of components (Ex: lmdz,inca) 57 INTEGER :: iGeneration = -1 !--- Generation number (>=0) 58 INTEGER :: iqParent = 0 !--- Parent index 59 INTEGER, ALLOCATABLE :: iqDescen(:) !--- Descendants index (in growing generation order) 60 INTEGER :: nqDescen = 0 !--- Number of descendants (all generations) 61 INTEGER :: nqChildren = 0 !--- Number of children (first generation) 62 INTEGER :: iadv = 10 !--- Advection scheme used 63 LOGICAL :: isAdvected = .FALSE. !--- "true" tracers: iadv > 0. COUNT(isAdvected )=nqtrue 64 LOGICAL :: isInPhysics = .TRUE. !--- "true" tracers: in tr_seri. COUNT(isInPhysics)=nqtottr 65 INTEGER :: iso_iGroup = 0 !--- Isotopes group index in isotopes(:) 66 INTEGER :: iso_iName = 0 !--- Isotope name index in isotopes(iso_iGroup)%trac(:) 67 INTEGER :: iso_iZone = 0 !--- Isotope zone index in isotopes(iso_iGroup)%zone(:) 68 INTEGER :: iso_iPhase = 0 !--- Isotope phase index in isotopes(iso_iGroup)%phase 69 END TYPE trac_type 70 !------------------------------------------------------------------------------------------------------------------------------ 71 TYPE :: isot_type !=== TYPE FOR AN ISOTOPES FAMILY DESCENDING ON TRACER "parent" 72 CHARACTER(LEN=maxlen) :: parent !--- Isotopes family name (parent tracer name ; ex: H2O) 47 TYPE :: isot_type !=== TYPE FOR AN ISOTOPES FAMILY DESCENDING ON TRACER "name" 48 CHARACTER(LEN=maxlen) :: name !--- Isotopes family name (example: H2O) 73 49 TYPE(keys_type), ALLOCATABLE :: keys(:) !--- Isotopes keys/values pairs list (length: niso) 74 50 LOGICAL :: check=.FALSE. !--- Flag for checking routines triggering … … 88 64 TYPE :: dataBase_type !=== TYPE FOR TRACERS SECTION 89 65 CHARACTER(LEN=maxlen) :: name !--- Section name 90 TYPE( trac_type), ALLOCATABLE :: trac(:) !--- Tracers descriptors66 TYPE(keys_type), ALLOCATABLE :: trac(:) !--- Tracers descriptors 91 67 END TYPE dataBase_type 92 68 !------------------------------------------------------------------------------------------------------------------------------ … … 139 115 140 116 !=== TRACERS AND ISOTOPES DESCRIPTORS, USED BY getKey 141 TYPE( trac_type), ALLOCATABLE, TARGET, SAVE :: tracers(:)117 TYPE(keys_type), ALLOCATABLE, TARGET, SAVE :: tracers(:) 142 118 TYPE(isot_type), ALLOCATABLE, TARGET, SAVE :: isotopes(:) 143 119 … … 193 169 !------------------------------------------------------------------------------------------------------------------------------ 194 170 CHARACTER(LEN=*), INTENT(IN) :: type_trac !--- List of components used 195 TYPE( trac_type), ALLOCATABLE, TARGET, OPTIONAL, INTENT(OUT) :: tracs(:) !--- Tracers descriptor for external storage171 TYPE(keys_type), ALLOCATABLE, TARGET, OPTIONAL, INTENT(OUT) :: tracs(:) !--- Tracers descriptor for external storage 196 172 LOGICAL, OPTIONAL, INTENT(IN) :: lRepr !--- Activate the HNO3 exceptions for REPROBUS 197 173 CHARACTER(LEN=maxlen), ALLOCATABLE :: s(:), sections(:), trac_files(:) 198 CHARACTER(LEN=maxlen) :: str, fname, tname, pname, cname 174 CHARACTER(LEN=maxlen) :: str, fname, tname, pname, cname, ttype 199 175 INTEGER :: nsec, ierr, it, ntrac, ns, ip, ix, fType 200 176 INTEGER, ALLOCATABLE :: iGen(:) … … 232 208 CALL msg('This file is for air tracers only', modname, ns == 3 .AND. it == 1) 233 209 CALL msg('This files specifies the transporting fluid', modname, ns == 4 .AND. it == 1) 234 k => tracers(it) %keys210 k => tracers(it) 235 211 236 212 !=== NAME OF THE TRACER … … 238 214 ix = strIdx(oldHNO3, s(3)) 239 215 IF(ix /= 0 .AND. lRep) tname = newHNO3(ix) !--- Exception for HNO3 (REPROBUS ONLY) 240 tracers(it)%name = tname !--- Set the name of the tracer 241 CALL addKey('name', tname, k) !--- Set the name of the tracer 242 tracers(it)%keys%name = tname !--- Copy tracers names in keys components 216 CALL addKey('name', tname, tracers) !--- Set the name of the tracer 217 ! tracers(it)%name = tname !--- Copy tracers names in keys components 243 218 244 219 !=== NAME OF THE COMPONENT 245 220 cname = type_trac !--- Name of the model component 246 221 IF(ANY([(addPhase('H2O', ip), ip = 1, nphases)] == tname)) cname = 'lmdz' 247 tracers(it)%component = cname !--- Set component 248 CALL addKey('component', cname, k) !--- Set the name of the model component 222 CALL addKey('component', cname, tracers) !--- Set the name of the model component 249 223 250 224 !=== NAME OF THE PARENT … … 255 229 IF(ix /= 0 .AND. lRep) pname = newHNO3(ix) !--- Exception for HNO3 (REPROBUS ONLY) 256 230 END IF 257 tracers(it)%parent = pname !--- Set the parent name 258 CALL addKey('parent', pname, k) 231 CALL addKey('parent', pname, tracers) !--- Set the parent name 259 232 260 233 !=== PHASE AND ADVECTION SCHEMES NUMBERS 261 tracers(it)%phase = known_phases(ip:ip) !--- Set the phase of the tracer (default: "g"azeous) 262 CALL addKey('phase', known_phases(ip:ip), k) !--- Set the phase of the tracer (default: "g"azeous) 234 CALL addKey('phase', known_phases(ip:ip), tracers) !--- Set the phase of the tracer (default: "g"azeous) 263 235 CALL addKey('hadv', s(1), k) !--- Set the horizontal advection schemes number 264 236 CALL addKey('vadv', s(2), k) !--- Set the vertical advection schemes number … … 266 238 CLOSE(90) 267 239 lerr = setGeneration(tracers); IF(lerr) RETURN !--- Set iGeneration and gen0Name 268 lerr = getKey('iGeneration', iGen, tracers(:)%keys) !--- Generation number 269 WHERE(iGen == 2) tracers(:)%type = 'tag' !--- Set type: 'tracer' or 'tag' 240 lerr = getKey('iGeneration', iGen, tracers(:)) !--- Generation number 270 241 DO it = 1, ntrac 271 CALL addKey('type', tracers(it)%type, tracers(it)%keys) !--- Set the type of tracer 242 ttype = 'tracer'; IF(iGen(it) == 2) ttype = 'tag' 243 CALL addKey('type', ttype, tracers(it)) !--- Set the type of tracer 272 244 END DO 273 245 lerr = checkTracers(tracers, fname, fname); IF(lerr) RETURN !--- Detect orphans and check phases … … 291 263 END IF 292 264 lerr = indexUpdate(tracers); IF(lerr) RETURN !--- Set iqParent, iqDescen, nqDescen, nqChildren 293 IF(PRESENT(tracs)) CALL MOVE_ALLOC(FROM=tracers, TO=tracs)265 IF(PRESENT(tracs)) tracs = tracers 294 266 END FUNCTION readTracersFiles 295 267 !============================================================================================================================== … … 339 311 ! Purpose: Read the sections "snames(is)" (pipe-separated list) from each "fnames(is)" 340 312 ! file and create the corresponding tracers set descriptors in the database "dBase": 341 ! * dBase(id)%name 342 ! * dBase(id)%trac(:) %name : tracers names343 ! * dBase(id)%trac(it)%key s%key(:): names of keys associated to tracer dBase(id)%trac(it)%name344 ! * dBase(id)%trac(it)% keys%val(:): values of keys associated to tracer dBase(id)%trac(it)%name313 ! * dBase(id)%name : section name 314 ! * dBase(id)%trac(:) : tracers descriptor (the key "name" of tracers(i) is the name of the ith tracer) 315 ! * dBase(id)%trac(it)%key(:): names of keys associated to tracer dBase(id)%trac(it)%name 316 ! * dBase(id)%trac(it)%val(:): values of keys associated to tracer dBase(id)%trac(it)%name 345 317 !------------------------------------------------------------------------------------------------------------------------------ 346 318 CHARACTER(LEN=*), INTENT(IN) :: fnames(:) !--- Files names … … 395 367 ndb= SIZE(dBase) !--- Current number of sections in the database 396 368 IF(PRESENT(defName)) THEN !--- Add default values to all the tracers 397 DO idb=n0,ndb; CALL addDefault(dBase(idb)%trac, defName); END DO !--- and remove the virtual tracer "defName" 369 DO idb=n0,ndb !--- and remove the virtual tracer "defName" 370 lerr = addDefault(dBase(idb)%trac, defName); IF(lerr) RETURN 371 END DO 398 372 END IF 399 373 ll = strParse(snam, '|', keys = sec) !--- Requested sections names … … 408 382 !------------------------------------------------------------------------------------------------------------------------------ 409 383 CHARACTER(LEN=maxlen), ALLOCATABLE :: s(:), v(:) 410 TYPE(trac_type), ALLOCATABLE :: tt(:) 411 TYPE(trac_type) :: tmp 384 TYPE(keys_type), ALLOCATABLE :: tt(:) 412 385 CHARACTER(LEN=1024) :: str, str2 413 386 CHARACTER(LEN=maxlen) :: secn … … 445 418 tt = dBase(ndb)%trac(:) 446 419 v(1) = s(1); s(1) = 'name' !--- Convert "name" into a regular key 447 tmp%name = v(1); tmp%keys = keys_type(v(1), s(:), v(:)) !--- Set %name and %keys 448 dBase(ndb)%trac = [tt(:), tmp] 449 DEALLOCATE(tt, tmp%keys%key, tmp%keys%val) 420 dBase(ndb)%trac = [tt(:), keys_type(s(:), v(:))] 421 DEALLOCATE(tt) 450 422 END IF 451 423 END DO … … 460 432 461 433 !============================================================================================================================== 462 SUBROUTINE addDefault(t, defName)434 LOGICAL FUNCTION addDefault(t, defName) RESULT(lerr) 463 435 !------------------------------------------------------------------------------------------------------------------------------ 464 436 ! Purpose: Add the keys from virtual tracer named "defName" (if any) and remove this virtual tracer. 465 437 !------------------------------------------------------------------------------------------------------------------------------ 466 TYPE( trac_type), ALLOCATABLE, TARGET, INTENT(INOUT) :: t(:)438 TYPE(keys_type), ALLOCATABLE, TARGET, INTENT(INOUT) :: t(:) 467 439 CHARACTER(LEN=*), INTENT(IN) :: defName 468 440 INTEGER :: jd, it, k 469 TYPE(keys_type), POINTER :: ky 470 TYPE(trac_type), ALLOCATABLE :: tt(:) 471 jd = strIdx(t(:)%name, defName) 441 CHARACTER(LEN=maxlen), ALLOCATABLE :: tname(:) 442 TYPE(keys_type), ALLOCATABLE :: tt(:) 443 lerr = getKey('name', tname, t(:)); IF(lerr) RETURN 444 jd = strIdx(tname(:), defName) 472 445 IF(jd == 0) RETURN 473 ky => t(jd)%keys 474 DO k = 1, SIZE(ky%key) !--- Loop on the keys of the tracer named "defName" 475 ! CALL addKey(ky%key(k), ky%val(k), t(:)%keys, .FALSE.) !--- Add key to all the tracers (no overwriting) 476 DO it = 1, SIZE(t); CALL addKey(ky%key(k), ky%val(k), t(it)%keys, .FALSE.); END DO 446 DO k = 1, SIZE(t(jd)%key) !--- Loop on the keys of the tracer named "defName" 447 ! CALL addKey(t(jd)%key(k), t(jd)%val(k), t(:), .FALSE.) !--- Add key to all the tracers (no overwriting) 448 DO it = 1, SIZE(t); CALL addKey(t(jd)%key(k), t(jd)%val(k), t(it), .FALSE.); END DO 477 449 END DO 478 450 tt = [t(1:jd-1),t(jd+1:SIZE(t))]; CALL MOVE_ALLOC(FROM=tt, TO=t) !--- Remove the virtual tracer named "defName" 479 END SUBROUTINEaddDefault480 !============================================================================================================================== 481 482 !============================================================================================================================== 483 SUBROUTINE subDefault(t, defName, lSubLocal)451 END FUNCTION addDefault 452 !============================================================================================================================== 453 454 !============================================================================================================================== 455 LOGICAL FUNCTION subDefault(t, defName, lSubLocal) RESULT(lerr) 484 456 !------------------------------------------------------------------------------------------------------------------------------ 485 457 ! Purpose: Substitute the keys from virtual tracer named "defName" (if any) and remove this virtual tracer. 486 458 ! Substitute the keys locally (for the current tracer) if the flag "lSubLocal" is .TRUE. 487 459 !------------------------------------------------------------------------------------------------------------------------------ 488 TYPE( trac_type), ALLOCATABLE, TARGET, INTENT(INOUT) :: t(:)460 TYPE(keys_type), ALLOCATABLE, TARGET, INTENT(INOUT) :: t(:) 489 461 CHARACTER(LEN=*), INTENT(IN) :: defName 490 462 LOGICAL, INTENT(IN) :: lSubLocal 491 463 INTEGER :: i0, it, ik 492 TYPE(keys_type), POINTER :: k0, ky 493 TYPE(trac_type), ALLOCATABLE :: tt(:) 494 i0 = strIdx(t(:)%name, defName) 464 TYPE(keys_type), ALLOCATABLE :: tt(:) 465 CHARACTER(LEN=maxlen), ALLOCATABLE :: tname(:) 466 lerr = getKey('name', tname, t(:)); IF(lerr) RETURN 467 i0 = strIdx(tname(:), defName) 495 468 IF(i0 == 0) RETURN 496 k0 => t(i0)%keys497 469 DO it = 1, SIZE(t); IF(it == i0) CYCLE !--- Loop on the tracers 498 ky => t(it)%keys499 470 500 471 !--- Substitute in the values of <key>=<val> pairs the keys defined in the virtual tracer "defName" 501 DO ik = 1, SIZE( k0%key); CALL strReplace(ky%val, k0%key(ik), k0%val(ik), .TRUE.); END DO472 DO ik = 1, SIZE(t(i0)%key); CALL strReplace(t(it)%val, t(i0)%key(ik), t(i0)%val(ik), .TRUE.); END DO 502 473 503 474 IF(.NOT.lSubLocal) CYCLE 504 475 !--- Substitute in the values of <key>=<val> pairs the keys defined locally (in the current tracer) 505 DO ik = 1, SIZE( ky%key); CALL strReplace(ky%val, ky%key(ik), ky%val(ik), .TRUE.); END DO476 DO ik = 1, SIZE(t(it)%key); CALL strReplace(t(it)%val, t(it)%key(ik), t(it)%val(ik), .TRUE.); END DO 506 477 END DO 507 478 tt = [t(1:i0-1),t(i0+1:SIZE(t))]; CALL MOVE_ALLOC(FROM=tt, TO=t) !--- Remove the virtual tracer named "defName" 508 479 509 END SUBROUTINEsubDefault480 END FUNCTION subDefault 510 481 !============================================================================================================================== 511 482 … … 518 489 ! * Default values are provided for these keys because they are necessary. 519 490 !------------------------------------------------------------------------------------------------------------------------------ 520 TYPE( trac_type), ALLOCATABLE, INTENT(INOUT) :: tr(:) !--- Tracer derived type vector491 TYPE(keys_type), ALLOCATABLE, INTENT(INOUT) :: tr(:) !--- Tracer derived type vector 521 492 CHARACTER(LEN=*), INTENT(IN) :: sname !--- Current section name 522 493 CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: fname !--- Tracers description file name 523 TYPE( trac_type), ALLOCATABLE :: ttr(:)494 TYPE(keys_type), ALLOCATABLE :: ttr(:) 524 495 CHARACTER(LEN=maxlen), ALLOCATABLE :: ta(:), pa(:), tname(:), parent(:), dType(:) 525 496 CHARACTER(LEN=maxlen) :: msg1, modname … … 529 500 lerr = .FALSE. 530 501 nt = SIZE(tr) 531 lerr = getKey('name', tname, tr(:) %keys); IF(lerr) RETURN532 lerr = getKey('parent', parent, tr(:) %keys, def = tran0); IF(lerr) RETURN533 lerr = getKey('type', dType, tr(:) %keys, def = 'tracer'); IF(lerr) RETURN502 lerr = getKey('name', tname, tr(:)); IF(lerr) RETURN 503 lerr = getKey('parent', parent, tr(:), def = tran0); IF(lerr) RETURN 504 lerr = getKey('type', dType, tr(:), def = 'tracer'); IF(lerr) RETURN 534 505 nq = 0 535 506 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ … … 537 508 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 538 509 !--- Extract useful keys: parent name, type, component name 539 tr(it)%component = sname 540 CALL addKey('component', sname, tr(it)%keys) 510 CALL addKey('component', sname, tr(it)) 541 511 542 512 !--- Determine the number of tracers and parents ; coherence checking … … 565 535 DO ipr = 1, npr !--- Loop on parents list elts 566 536 DO itr = 1, ntr !--- Loop on tracers list elts 567 ttr(iq)%keys%name = TRIM(ta(itr)) 568 ttr(iq)%keys%key = tr(it)%keys%key 569 ttr(iq)%keys%val = tr(it)%keys%val 570 ttr(iq)%name = TRIM(ta(itr)) 571 ttr(iq)%parent = TRIM(pa(ipr)) 572 ttr(iq)%type = dType(it) 573 ttr(iq)%component = sname 574 CALL addKey('name', ta(itr), ttr(iq)%keys) 575 CALL addKey('parent', pa(ipr), ttr(iq)%keys) 576 CALL addKey('type', dType(it), ttr(iq)%keys) 577 CALL addKey('component', sname, ttr(iq)%keys) 537 ttr(iq)%key = tr(it)%key 538 ttr(iq)%val = tr(it)%val 539 CALL addKey('name', ta(itr), ttr(iq)) 540 CALL addKey('parent', pa(ipr), ttr(iq)) 541 CALL addKey('type', dType(it), ttr(iq)) 542 CALL addKey('component', sname, ttr(iq)) 578 543 iq = iq + 1 579 544 END DO … … 597 562 ! Check also for orphan tracers (tracers without parent). 598 563 !------------------------------------------------------------------------------------------------------------------------------ 599 TYPE( trac_type), INTENT(INOUT) :: tr(:) !--- Tracer derived type vector564 TYPE(keys_type), INTENT(INOUT) :: tr(:) !--- Tracer derived type vector 600 565 INTEGER :: iq, jq, ig 601 566 CHARACTER(LEN=maxlen), ALLOCATABLE :: parent(:), tname(:) … … 603 568 CHARACTER(LEN=maxlen) :: modname 604 569 modname = 'setGeneration' 605 lerr = getKey('name', tname, ky=tr(:) %keys); IF(lerr) RETURN606 lerr = getKey('parent', parent, ky=tr(:) %keys); IF(lerr) RETURN570 lerr = getKey('name', tname, ky=tr(:)); IF(lerr) RETURN 571 lerr = getKey('parent', parent, ky=tr(:)); IF(lerr) RETURN 607 572 DO iq = 1, SIZE(tr) 608 573 jq = iq; ig = 0 … … 613 578 ig = ig + 1 614 579 END DO 615 tr(iq)%gen0Name = tname(jq) 616 tr(iq)%iGeneration = ig 617 CALL addKey('iGeneration', ig, tr(iq)%keys) 618 CALL addKey('gen0Name', tname(jq), tr(iq)%keys) 580 CALL addKey('iGeneration', ig, tr(iq)) 581 CALL addKey('gen0Name', tname(jq), tr(iq)) 619 582 END DO 620 583 END FUNCTION setGeneration … … 629 592 ! * check wether the phases are known or not (elements of "known_phases") 630 593 !------------------------------------------------------------------------------------------------------------------------------ 631 TYPE( trac_type), INTENT(IN) :: tr(:) !--- Tracer derived typevector594 TYPE(keys_type), INTENT(IN) :: tr(:) !--- Tracers description vector 632 595 CHARACTER(LEN=*), INTENT(IN) :: sname !--- Section name 633 596 CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: fname !--- File name … … 644 607 mesg = 'Check section "'//TRIM(sname)//'"' 645 608 IF(PRESENT(fname)) mesg=TRIM(mesg)//' in file "'//TRIM(fname)//'"' 646 lerr = getKey('iGeneration', iGen, tr(:) %keys);IF(lerr) RETURN647 lerr = getKey('name', tname, tr(:) %keys);IF(lerr) RETURN609 lerr = getKey('iGeneration', iGen, tr(:)); IF(lerr) RETURN 610 lerr = getKey('name', tname, tr(:)); IF(lerr) RETURN 648 611 649 612 !=== CHECK FOR ORPHAN TRACERS … … 652 615 !=== CHECK PHASES 653 616 DO iq = 1, nq; IF(iGen(iq) /= 0) CYCLE !--- Generation O only is checked 654 IF(getKey(['phases','phase '], pha, iq, tr(:) %keys, lDisp=.FALSE.)) pha = 'g' !--- Phase617 IF(getKey(['phases','phase '], pha, iq, tr(:), lDisp=.FALSE.)) pha = 'g' !--- Phase 655 618 np = LEN_TRIM(pha); bp(iq)=' ' 656 619 DO ip = 1, np; p = pha(ip:ip); IF(INDEX(known_phases, p) == 0) bp(iq) = TRIM(bp(iq))//p; END DO … … 667 630 ! Purpose: Make sure that tracers are not repeated. 668 631 !------------------------------------------------------------------------------------------------------------------------------ 669 TYPE( trac_type), INTENT(IN) :: tr(:) !--- Tracer derived typevector632 TYPE(keys_type), INTENT(IN) :: tr(:) !--- Tracers description vector 670 633 CHARACTER(LEN=*), INTENT(IN) :: sname !--- Section name 671 634 CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: fname !--- File name … … 684 647 nq=SIZE(tr,DIM=1); lerr=.FALSE. !--- Number of lines ; error flag 685 648 tdup(:) = '' 686 lerr = getKey('name', tname, tr %keys); IF(lerr) RETURN687 lerr = getKey('type', dType, tr %keys); IF(lerr) RETURN688 lerr = getKey('iGeneration', iGen, tr %keys); IF(lerr) RETURN649 lerr = getKey('name', tname, tr); IF(lerr) RETURN 650 lerr = getKey('type', dType, tr); IF(lerr) RETURN 651 lerr = getKey('iGeneration', iGen, tr); IF(lerr) RETURN 689 652 DO iq = 1, nq 690 653 IF(dType(iq) == 'tag') CYCLE !--- Tags can be repeated … … 698 661 DO k = 1, nq 699 662 IF(.NOT.ll(k)) CYCLE !--- Skip tracers different from current one 700 IF(getKey(['phases','phase '], phase, k, tr %keys, lDisp=.FALSE.)) phase='g'!--- Get current phases663 IF(getKey(['phases','phase '], phase, k, tr, lDisp=.FALSE.)) phase='g'!--- Get current phases 701 664 IF(INDEX(phase, p) /= 0) np = np + 1 !--- One more appearance of current tracer with phase "p" 702 665 END DO … … 718 681 ! Purpose: Expand the phases in the tracers descriptor "tr". Phases are not repeated for a tracer, thanks to "checkUnique". 719 682 !------------------------------------------------------------------------------------------------------------------------------ 720 TYPE( trac_type), ALLOCATABLE, INTENT(INOUT) :: tr(:) !--- Tracer derived typevector721 !------------------------------------------------------------------------------------------------------------------------------ 722 TYPE( trac_type), ALLOCATABLE :: ttr(:)683 TYPE(keys_type), ALLOCATABLE, INTENT(INOUT) :: tr(:) !--- Tracers description vector 684 !------------------------------------------------------------------------------------------------------------------------------ 685 TYPE(keys_type), ALLOCATABLE :: ttr(:) 723 686 INTEGER, ALLOCATABLE :: i0(:), iGen(:) 724 687 CHARACTER(LEN=maxlen), ALLOCATABLE :: tname(:), gen0N(:), phase(:), parents(:), dType(:) … … 732 695 nq = SIZE(tr, DIM=1) 733 696 nt = 0 734 lerr = getKey('name', tname, tr %keys); IF(lerr) RETURN!--- Names of the tracers735 lerr = getKey('gen0Name', gen0N, tr %keys); IF(lerr) RETURN!--- Names of the tracers of first generation736 lerr = getKey('iGeneration', iGen, tr %keys); IF(lerr) RETURN!--- Generation number737 lerr = getKey('phases', phase, tr %keys); IF(lerr) RETURN!--- Phases names738 lerr = getKey('parent', parents, tr %keys); IF(lerr) RETURN!--- Parents names739 lerr = getKey('type', dType, tr %keys); IF(lerr) RETURN!--- Tracers types ('tracer' or 'tag')697 lerr = getKey('name', tname, tr); IF(lerr) RETURN !--- Names of the tracers 698 lerr = getKey('gen0Name', gen0N, tr); IF(lerr) RETURN !--- Names of the tracers of first generation 699 lerr = getKey('iGeneration', iGen, tr); IF(lerr) RETURN !--- Generation number 700 lerr = getKey('phases', phase, tr); IF(lerr) RETURN !--- Phases names 701 lerr = getKey('parent', parents, tr); IF(lerr) RETURN !--- Parents names 702 lerr = getKey('type', dType, tr); IF(lerr) RETURN !--- Tracers types ('tracer' or 'tag') 740 703 DO iq = 1, nq !--- GET THE NUMBER OF TRACERS 741 704 IF(iGen(iq) /= 0) CYCLE !--- Only deal with generation 0 tracers … … 763 726 IF(lTag) nam = TRIM(nam)//'_'//TRIM(tname(iq)) !--- <parent>_<name> for tags 764 727 ttr(it) = tr(iq) !--- Same <key>=<val> pairs 765 ttr(it)%name = TRIM(nam) !--- Name with possibly phase suffix 766 ttr(it)%keys%name = TRIM(nam) !--- Name inside the keys decriptor 767 ttr(it)%phase = p !--- Single phase entry 768 CALL addKey('name', nam, ttr(it)%keys) 769 CALL addKey('phase', p, ttr(it)%keys) 728 CALL addKey('name', nam, ttr(it)) !--- Name with possibly phase suffix 729 CALL addKey('phase', p, ttr(it)) !--- Single phase entry 770 730 IF(lExt) THEN 771 731 parent = parents(iq); IF(iGen(iq) > 0) parent = addPhase(parent, p) 772 732 gen0Nm = gen0N(iq); IF(iGen(iq) > 0) gen0Nm = addPhase(gen0Nm, p) 773 ttr(it)%parent = parent 774 ttr(it)%gen0Name = gen0Nm 775 CALL addKey('parent', parent, ttr(it)%keys) 776 CALL addKey('gen0Name', gen0Nm, ttr(it)%keys) 733 CALL addKey('parent', parent, ttr(it)) 734 CALL addKey('gen0Name', gen0Nm, ttr(it)) 777 735 END IF 778 736 it = it+1 … … 782 740 END DO 783 741 CALL MOVE_ALLOC(FROM=ttr, TO=tr) 784 CALL delKey(['phases'], tr) !--- Remove few keys entries742 CALL delKey(['phases'], tr) !--- Remove "phases" key, useless since "phase" is defined 785 743 786 744 END FUNCTION expandPhases … … 797 755 ! TO BE ADDED IF NECESSARY: HIGHER MOMENTS AT THE END 798 756 !------------------------------------------------------------------------------------------------------------------------------ 799 TYPE(trac_type), INTENT(INOUT) :: tr(:) !--- Tracer derived type vector 800 !------------------------------------------------------------------------------------------------------------------------------ 801 TYPE(trac_type), ALLOCATABLE :: tr2(:) 802 INTEGER, ALLOCATABLE :: iy(:), iz(:) 803 INTEGER, ALLOCATABLE :: iGen(:) 757 TYPE(keys_type), INTENT(INOUT) :: tr(:) !--- Tracers description vector 758 !------------------------------------------------------------------------------------------------------------------------------ 759 TYPE(keys_type), ALLOCATABLE :: tr2(:) 760 INTEGER, ALLOCATABLE :: iy(:), iz(:), iGen(:) 804 761 CHARACTER(LEN=maxlen), ALLOCATABLE :: tname(:), gen0N(:) 805 762 INTEGER :: ig, ng, iq, jq, ip, nq, n, ix(SIZE(tr)), k … … 807 764 ! tr2 is introduced in order to cope with a bug in gfortran 4.8.5 compiler 808 765 !------------------------------------------------------------------------------------------------------------------------------ 809 lerr = getKey('iGeneration', iGen, tr %keys); IF(lerr) RETURN!--- Generation number766 lerr = getKey('iGeneration', iGen, tr); IF(lerr) RETURN !--- Generation number 810 767 nq = SIZE(tr) 811 768 DO ip = nphases, 1, -1 812 lerr = getKey('name', tname, tr %keys); IF(lerr) RETURN!--- Names of the tracers of first generation769 lerr = getKey('name', tname, tr); IF(lerr) RETURN !--- Names of the tracers of first generation 813 770 iq = strIdx(tname, addPhase('H2O', ip)) 814 771 IF(iq == 0) CYCLE … … 826 783 END DO 827 784 ELSE 828 lerr = getKey('gen0Name', gen0N, tr%keys); IF(lerr) RETURN!--- Names of the tracers iq = 1785 lerr = getKey('gen0Name', gen0N, tr); IF(lerr) RETURN !--- Names of the tracers iq = 1 829 786 DO jq = 1, nq !--- Loop on generation 0 tracers 830 787 IF(iGen(jq) /= 0) CYCLE !--- Skip generations /= 0 … … 848 805 LOGICAL FUNCTION mergeTracers(sections, tr) RESULT(lerr) 849 806 TYPE(dataBase_type), TARGET, INTENT(IN) :: sections(:) 850 TYPE(trac_type), ALLOCATABLE, INTENT(OUT) :: tr(:) 851 TYPE(trac_type), POINTER :: t1(:), t2(:) 852 TYPE(keys_type), POINTER :: k1(:), k2(:) 807 TYPE(keys_type), ALLOCATABLE, INTENT(OUT) :: tr(:) 808 TYPE(keys_type), POINTER :: t1(:), t2(:) 853 809 INTEGER, ALLOCATABLE :: ixct(:), ixck(:) 854 810 INTEGER :: is, ik, ik1, ik2, nk2, i1, i2, nt2 … … 858 814 lerr = .FALSE. 859 815 keys = ['parent ', 'type ', 'iGeneration'] !--- Mandatory keys 860 t1 => sections(1)%trac(:) ; k1 => t1(:)%keys !--- Alias: first tracers section, corresponding keys861 lerr = getKey('name', n1, k1); IF(lerr) RETURN !--- Names of the tracers816 t1 => sections(1)%trac(:) !--- Alias: first tracers section 817 lerr = getKey('name', n1, t1); IF(lerr) RETURN !--- Names of the tracers 862 818 tr = t1 863 819 !---------------------------------------------------------------------------------------------------------------------------- … … 865 821 !---------------------------------------------------------------------------------------------------------------------------- 866 822 t2 => sections(is)%trac(:) !--- Alias: current tracers section 867 k2 => t2(:)%keys 868 lerr = getKey('name', n2, k2); IF(lerr) RETURN !--- Names of the tracers 823 lerr = getKey('name', n2, t2); IF(lerr) RETURN !--- Names of the tracers 869 824 nt2 = SIZE(t2(:), DIM=1) !--- Number of tracers in section 870 825 ixct = strIdx(n1(:), n2(:)) !--- Indexes of common tracers … … 874 829 CALL msg(n1(PACK(ixct, MASK = ixct/=0)), modname, nmax=128) !--- Display duplicates (the 128 first at most) 875 830 !-------------------------------------------------------------------------------------------------------------------------- 876 DO i2=1,nt2; tnam = TRIM( t2(i2)%name)!=== LOOP ON COMMON TRACERS831 DO i2=1,nt2; tnam = TRIM(n2(i2)) !=== LOOP ON COMMON TRACERS 877 832 !-------------------------------------------------------------------------------------------------------------------------- 878 833 i1 = ixct(i2); IF(i1 == 0) CYCLE !--- Idx in t1(:) ; skip new tracers … … 881 836 s1=' of "'//TRIM(tnam)//'" in "'//TRIM(sections(is)%name)//'" not matching previous value' 882 837 DO ik = 1, SIZE(keys) 883 lerr = getKey(keys(ik), v1, i1, k1)884 lerr = getKey(keys(ik), v2, i2, k2)838 lerr = getKey(keys(ik), v1, i1, t1) 839 lerr = getKey(keys(ik), v2, i2, t2) 885 840 lerr = v1 /= v2; IF(fmsg(TRIM(keys(ik))//TRIM(s1), modname, lerr)) RETURN 886 841 END DO 887 842 888 !=== GET THE INDICES IN tr(i2)%key s%key(:) OF THE KEYS ALSO PRESENT IN tr(i1)%keys%key(:)889 nk2 = SIZE( k2(i2)%key(:)) !--- Keys number in current section890 ixck = strIdx( k1(i1)%key(:), k2(i2)%key(:)) !--- Common keys indexes891 !--- APPEND THE NEW KEYS PAIRS IN tr(i1)%key s%key(:)892 tr(i1)%key s%key = [ tr(i1)%keys%key, PACK(tr(i2)%keys%key, MASK = ixck==0)]893 tr(i1)% keys%val = [ tr(i1)%keys%val, PACK(tr(i2)%keys%val, MASK = ixck==0)]843 !=== GET THE INDICES IN tr(i2)%key(:) OF THE KEYS ALSO PRESENT IN tr(i1)%key(:) 844 nk2 = SIZE(t2(i2)%key(:)) !--- Keys number in current section 845 ixck = strIdx(t1(i1)%key(:), t2(i2)%key(:)) !--- Common keys indexes 846 !--- APPEND THE NEW KEYS PAIRS IN tr(i1)%key(:) 847 tr(i1)%key = [ tr(i1)%key, PACK(tr(i2)%key, MASK = ixck==0)] 848 tr(i1)%val = [ tr(i1)%val, PACK(tr(i2)%val, MASK = ixck==0)] 894 849 895 850 !=== KEEP TRACK OF THE COMPONENTS NAMES: COMA-SEPARATED LIST 896 lerr = getKey('component', v1, i1, k1) 897 lerr = getKey('component', v2, i2, k2) 898 tr(i1)%component = TRIM(v1)//','//TRIM(v2) 899 CALL addKey('component', TRIM(v1)//','//TRIM(v2), tr(i1)%keys) 851 lerr = getKey('component', v1, i1, t1) 852 lerr = getKey('component', v2, i2, t2) 853 CALL addKey('component', TRIM(v1)//','//TRIM(v2), tr(i1)) 900 854 901 855 !=== FOR TRACERS COMMON TO PREVIOUS AND CURRENT SECTIONS: CHECK WETHER SOME KEYS HAVE DIFFERENT VALUES ; KEEP OLD ONE 902 856 DO ik2 = 1, nk2 !--- Collect the corresponding indices 903 857 ik1 = ixck(ik2); IF(ik1 == 0) CYCLE 904 IF( k1(i1)%val(ik1) == k2(i2)%val(ik2)) ixck(ik2)=0858 IF(t1(i1)%val(ik1) == t2(i2)%val(ik2)) ixck(ik2)=0 905 859 END DO 906 860 IF(ALL(ixck==0)) CYCLE !--- No identical keys with /=values => nothing to display 907 861 CALL msg('Key(s)'//TRIM(s1), modname) !--- Display the keys with /=values (names list) 908 862 DO ik2 = 1, nk2 !--- Loop on keys found in both t1(:) and t2(:) 909 knam = k2(i2)%key(ik2) !--- Name of the current key863 knam = t2(i2)%key(ik2) !--- Name of the current key 910 864 ik1 = ixck(ik2) !--- Corresponding index in t1(:) 911 865 IF(ik1 == 0) CYCLE !--- New keys are skipped 912 v1 = k1(i1)%val(ik1); v2 = k2(i2)%val(ik2) !--- Key values in t1(:) and t2(:)866 v1 = t1(i1)%val(ik1); v2 = t2(i2)%val(ik2) !--- Key values in t1(:) and t2(:) 913 867 CALL msg(' * '//TRIM(knam)//'='//TRIM(v2)//' ; previous value kept:'//TRIM(v1), modname) 914 868 END DO … … 925 879 LOGICAL FUNCTION cumulTracers(sections, tr, lRename) RESULT(lerr) 926 880 TYPE(dataBase_type), TARGET, INTENT(IN) :: sections(:) 927 TYPE( trac_type), ALLOCATABLE, INTENT(OUT) :: tr(:)881 TYPE(keys_type), ALLOCATABLE, INTENT(OUT) :: tr(:) 928 882 LOGICAL, OPTIONAL, INTENT(IN) :: lRename !--- .TRUE.: add a section suffix to identical names 929 883 CHARACTER(LEN=maxlen) :: tnam_new, modname … … 934 888 tr = [( sections(is)%trac(:), is = 1, SIZE(sections) )] !--- Concatenated tracers vector 935 889 IF(PRESENT(lRename)) THEN; IF(lRename) RETURN; END IF !--- No renaming: finished 936 lerr = getKey('name', tname, tr %keys); IF(lerr) RETURN!--- Names937 lerr = getKey('parent', parent, tr %keys); IF(lerr) RETURN!--- Parents938 lerr = getKey('component', comp, tr %keys); IF(lerr) RETURN!--- Component name890 lerr = getKey('name', tname, tr); IF(lerr) RETURN !--- Names 891 lerr = getKey('parent', parent, tr); IF(lerr) RETURN !--- Parents 892 lerr = getKey('component', comp, tr); IF(lerr) RETURN !--- Component name 939 893 !---------------------------------------------------------------------------------------------------------------------------- 940 894 DO iq = 1, SIZE(tr); IF(COUNT(tname == tname(iq)) == 1) CYCLE !=== LOOP ON TRACERS 941 895 !---------------------------------------------------------------------------------------------------------------------------- 942 896 tnam_new = TRIM(tname(iq))//'_'//TRIM(comp(iq)) !--- Same with section extension 943 CALL addKey('name', tnam_new, tr(iq)%keys) !--- Modify tracer name 944 tr(iq)%name = TRIM(tnam_new) !--- Modify tracer name 897 CALL addKey('name', tnam_new, tr(iq)) !--- Modify tracer name 945 898 !-------------------------------------------------------------------------------------------------------------------------- 946 899 DO jq = 1, SIZE(tr); IF(parent(jq) /= tname(iq)) CYCLE !=== LOOP ON TRACERS PARENTS 947 900 !-------------------------------------------------------------------------------------------------------------------------- 948 CALL addKey('parent', tnam_new, tr(jq)%keys) !--- Modify tracer name 949 tr(jq)%parent = TRIM(tnam_new) !--- Modify tracer name 901 CALL addKey('parent', tnam_new, tr(jq)) !--- Modify tracer name 950 902 !-------------------------------------------------------------------------------------------------------------------------- 951 903 END DO … … 994 946 tmp = int2str([(iq, iq=1, nq)]) 995 947 ELSE 996 lerr = getKey(nam, tmp, dBase(idb)%trac(:) %keys, lDisp=lMandatory)948 lerr = getKey(nam, tmp, dBase(idb)%trac(:), lDisp=lMandatory) 997 949 END IF 998 950 IF(lerr) THEN; lerr = lMandatory; RETURN; END IF … … 1013 965 LOGICAL FUNCTION aliasTracer(tname, trac, alias) RESULT(lerr) !=== TRACER NAMED "tname" - SCALAR 1014 966 CHARACTER(LEN=*), INTENT(IN) :: tname 1015 TYPE( trac_type), TARGET, INTENT(IN) :: trac(:)1016 TYPE( trac_type), POINTER, INTENT(OUT) :: alias967 TYPE(keys_type), TARGET, INTENT(IN) :: trac(:) 968 TYPE(keys_type), POINTER, INTENT(OUT) :: alias 1017 969 INTEGER :: it 1018 970 CHARACTER(LEN=maxlen), ALLOCATABLE :: tnames(:) 1019 971 alias => NULL() 1020 lerr = getKey('name', tnames, trac(:) %keys)972 lerr = getKey('name', tnames, trac(:)) 1021 973 it = strIdx(tnames, tname) 1022 974 lerr = it /= 0; IF(.NOT.lerr) alias => trac(it) … … 1024 976 !============================================================================================================================== 1025 977 LOGICAL FUNCTION trSubset_Indx(trac, idx, alias) RESULT(lerr) !=== TRACERS WITH INDICES "idx(:)" - VECTOR 1026 TYPE( trac_type), ALLOCATABLE, INTENT(IN) :: trac(:)978 TYPE(keys_type), ALLOCATABLE, INTENT(IN) :: trac(:) 1027 979 INTEGER, INTENT(IN) :: idx(:) 1028 TYPE( trac_type), ALLOCATABLE, INTENT(OUT) :: alias(:)980 TYPE(keys_type), ALLOCATABLE, INTENT(OUT) :: alias(:) 1029 981 alias = trac(idx) 1030 982 lerr = indexUpdate(alias) … … 1032 984 !------------------------------------------------------------------------------------------------------------------------------ 1033 985 LOGICAL FUNCTION trSubset_Name(trac, tname, alias) RESULT(lerr) !=== TRACERS NAMED "tname(:)" - VECTOR 1034 TYPE( trac_type), ALLOCATABLE, INTENT(IN) :: trac(:)986 TYPE(keys_type), ALLOCATABLE, INTENT(IN) :: trac(:) 1035 987 CHARACTER(LEN=*), INTENT(IN) :: tname(:) 1036 TYPE( trac_type), ALLOCATABLE, INTENT(OUT) :: alias(:)988 TYPE(keys_type), ALLOCATABLE, INTENT(OUT) :: alias(:) 1037 989 CHARACTER(LEN=maxlen), ALLOCATABLE :: tnames(:) 1038 lerr = getKey('name', tnames, trac(:) %keys)990 lerr = getKey('name', tnames, trac(:)) 1039 991 alias = trac(strIdx(tnames, tname)) 1040 992 lerr = indexUpdate(alias) … … 1042 994 !============================================================================================================================== 1043 995 LOGICAL FUNCTION trSubset_gen0Name(trac, gen0Nm, alias) RESULT(lerr) !=== TRACERS OF COMMON 1st GENERATION ANCESTOR 1044 TYPE( trac_type), ALLOCATABLE, INTENT(IN) :: trac(:)996 TYPE(keys_type), ALLOCATABLE, INTENT(IN) :: trac(:) 1045 997 CHARACTER(LEN=*), INTENT(IN) :: gen0Nm 1046 TYPE( trac_type), ALLOCATABLE, INTENT(OUT) :: alias(:)998 TYPE(keys_type), ALLOCATABLE, INTENT(OUT) :: alias(:) 1047 999 CHARACTER(LEN=maxlen), ALLOCATABLE :: gen0N(:) 1048 lerr = getKey('gen0Name', gen0N, trac(:) %keys)1000 lerr = getKey('gen0Name', gen0N, trac(:)) 1049 1001 alias = trac(strFind(delPhase(gen0N), gen0Nm)) 1050 1002 lerr = indexUpdate(alias) … … 1054 1006 1055 1007 !============================================================================================================================== 1056 !=== UPDATE THE INDEXES iqParent, iqDescen d AND iGeneration IN THE TRACERS DESCRIPTOR LIST "tr" (USEFULL FOR SUBSETS)=========1008 !=== UPDATE THE INDEXES iqParent, iqDescen, nqDescen, nqChildren IN THE TRACERS DESCRIPTOR LIST "tr" ========================== 1057 1009 !============================================================================================================================== 1058 1010 LOGICAL FUNCTION indexUpdate(tr) RESULT(lerr) 1059 TYPE( trac_type), INTENT(INOUT) :: tr(:)1011 TYPE(keys_type), INTENT(INOUT) :: tr(:) 1060 1012 INTEGER :: iq, jq, nq, ig, nGen 1061 1013 INTEGER, ALLOCATABLE :: iqDescen(:), ix(:), iy(:) 1062 1014 CHARACTER(LEN=maxlen), ALLOCATABLE :: tnames(:), parent(:) 1063 1015 INTEGER, DIMENSION(SIZE(tr)) :: iqParent, iGen 1064 lerr = getKey('name', tnames, tr %keys); IF(lerr) RETURN!--- Names1065 lerr = getKey('parent', parent, tr %keys); IF(lerr) RETURN!--- Parents1016 lerr = getKey('name', tnames, tr); IF(lerr) RETURN !--- Names 1017 lerr = getKey('parent', parent, tr); IF(lerr) RETURN !--- Parents 1066 1018 nq = SIZE(tr) 1067 1019 1068 !=== iqParent , iGeneration1020 !=== iqParent 1069 1021 DO iq = 1, nq; iGen(iq) = 0; jq = iq 1070 1022 iqParent(iq) = strIdx(tnames, parent(iq)) 1071 1023 DO; jq = strIdx(tnames, parent(jq)); IF(jq == 0) EXIT; iGen(iq) = iGen(iq) + 1; END DO 1072 CALL addKey('iqParent', parent(iq), tr(iq)%keys) 1073 CALL addKey('iqGeneration', iGen(iq), tr(iq)%keys) 1024 CALL addKey('iqParent', iqParent(iq), tr(iq)) 1074 1025 END DO 1075 1026 … … 1078 1029 DO iq = 1, nq 1079 1030 ix = [iq]; ALLOCATE(iqDescen(0)) 1031 CALL addKey('nqChildren', 0, tr(iq)) 1080 1032 DO ig = iGen(iq)+1, nGen 1081 1033 iy = find(iqParent, ix); iqDescen = [iqDescen, iy]; ix = iy 1082 1034 IF(ig /= iGen(iq)+1) CYCLE 1083 CALL addKey('nqChildren', SIZE(iqDescen), tr(iq)%keys) 1084 tr(iq)%nqChildren = SIZE(iqDescen) 1035 CALL addKey('nqChildren', SIZE(iqDescen), tr(iq)) 1085 1036 END DO 1086 CALL addKey('iqDescen', strStack(int2str(iqDescen)), tr(iq)%keys) 1087 CALL addKey('nqDescen', SIZE(iqDescen), tr(iq)%keys) 1088 tr(iq)%iqDescen = iqDescen 1089 tr(iq)%nqDescen = SIZE(iqDescen) 1037 CALL addKey('iqDescen', strStack(int2str(iqDescen)), tr(iq)) 1038 CALL addKey('nqDescen', SIZE(iqDescen), tr(iq)) 1090 1039 DEALLOCATE(iqDescen) 1091 1040 END DO … … 1095 1044 1096 1045 !============================================================================================================================== 1097 !=== READ FILE "fnam" TO APPEND THE "dBase" TRACERS DATABASE WITH AS MUCH SECTIONS AS PARENTS NAMES IN "isot(:)%parent":====1098 !=== * Each section dBase(i)%name contains the isotopes "dBase(i)%trac(:)" descending on "dBase(i)%name"="iso(i)% parent"====1046 !=== READ FILE "fnam" TO APPEND THE "dBase" TRACERS DATABASE WITH AS MUCH SECTIONS AS ISOTOPES CLASSES IN "isot(:)%name": ==== 1047 !=== * Each section dBase(i)%name contains the isotopes "dBase(i)%trac(:)" descending on "dBase(i)%name"="iso(i)%name" ==== 1099 1048 !=== * For each isotopes class, the <key>=<val> vector of each tracer is moved into the isotopes descriptor "isot" ==== 1100 1049 !=== NOTES: ==== 1101 1050 !=== * Most of the "isot" components have been defined in the calling routine (processIsotopes): ==== 1102 !=== parent, nzone, zone(:), niso, keys(:)%name, ntiso, trac(:), nphas, phas, iqIsoPha(:,:), itZonPhi(:,:)====1051 !=== name, nzone, zone(:), niso, keys(:)%name, ntiso, trac(:), nphas, phas, iqIsoPha(:,:), itZonPhi(:,:) ==== 1103 1052 !=== * Same syntax for isotopes file and "tracer.def": a tracers section contains one line for each of its isotopes ==== 1104 1053 !=== * Each tracers section can contain a "params" virtual isotope line of isotopes parameters default values ==== … … 1109 1058 LOGICAL FUNCTION readIsotopesFile(fnam, isot) RESULT(lerr) 1110 1059 CHARACTER(LEN=*), INTENT(IN) :: fnam !--- Input file name 1111 TYPE(isot_type), TARGET, INTENT(INOUT) :: isot(:) !--- Isotopes descriptors (field % parentmust be defined!)1060 TYPE(isot_type), TARGET, INTENT(INOUT) :: isot(:) !--- Isotopes descriptors (field %name must be defined!) 1112 1061 LOGICAL :: lFound 1113 1062 INTEGER :: is, iis, it, idb, ndb, nb0 1114 CHARACTER(LEN=maxlen), ALLOCATABLE :: vals(:) 1063 CHARACTER(LEN=maxlen), ALLOCATABLE :: vals(:), tname(:), iname(:) 1115 1064 CHARACTER(LEN=maxlen) :: modname 1116 TYPE( trac_type), POINTER :: tt(:),t1065 TYPE(keys_type), POINTER :: t 1117 1066 TYPE(dataBase_type), ALLOCATABLE :: tdb(:) 1118 1067 modname = 'readIsotopesFile' 1119 1068 1120 1069 !--- THE INPUT FILE MUST BE PRESENT 1121 INQUIRE(FILE=TRIM(fnam), EXIST=lFound); lerr = .NOT.lFound 1122 IF(fmsg('Missing isotopes parameters file "'//TRIM(fnam)//'"', modname, lerr)) RETURN 1123 1124 !--- READ THE FILE SECTIONS, ONE EACH PARENT TRACER 1070 INQUIRE(FILE=TRIM(fnam), EXIST=lFound) 1071 lerr = .NOT.lFound 1072 CALL msg('Missing isotopes parameters file "'//TRIM(fnam)//'"', modname, lerr) 1073 IF(lerr) RETURN 1074 1075 !--- READ THE FILE SECTIONS, ONE EACH ISOTOPES CLASS (FIEDL %name) 1125 1076 nb0 = SIZE(dBase, DIM=1)+1 !--- Next database element index 1126 lerr = readSections(fnam,strStack(isot(:)% parent,'|')); IF(lerr) RETURN !--- Read sections, one each parent tracer1077 lerr = readSections(fnam,strStack(isot(:)%name,'|')); IF(lerr) RETURN !--- Read sections, one each isotopes class %name 1127 1078 ndb = SIZE(dBase, DIM=1) !--- Current database size 1128 1079 DO idb = nb0, ndb … … 1130 1081 1131 1082 !--- GET FEW GLOBAL KEYS FROM "def" FILES AND ADD THEM TO THE 'params' SECTION 1132 CALL addKeysFromDef(dBase(idb)%trac, 'params') 1083 ! lerr = addKeysFromDef(dBase(idb)%trac, 'params'); IF(lerr) RETURN 1133 1084 1134 1085 !--- SUBSTITUTE THE KEYS DEFINED IN THE 'params' VIRTUAL TRACER ; SUBSTITUTE LOCAL KEYS ; REMOVE 'params' VIRTUAL TRACER 1135 CALL subDefault(dBase(idb)%trac, 'params', .TRUE.) 1136 1137 tt => dBase(idb)%trac 1086 lerr = subDefault(dBase(idb)%trac, 'params', .TRUE.); IF(lerr) RETURN 1138 1087 1139 1088 !--- REDUCE THE EXPRESSIONS TO OBTAIN SCALARS AND TRANSFER THEM TO THE "isot" ISOTOPES DESCRIPTORS VECTOR 1089 lerr = getKey('name', tname, dBase(idb)%trac); IF(lerr) RETURN 1090 lerr = getKey('name', iname, isot(iis)%keys); IF(lerr) RETURN 1140 1091 DO it = 1, SIZE(dBase(idb)%trac) 1141 1092 t => dBase(idb)%trac(it) 1142 is = strIdx(i sot(iis)%keys(:)%name, t%name) !--- Index in "isot(iis)%keys(:)%name" of isotope "t%name"1093 is = strIdx(iname, tname(it)) !--- Index in "iname(:)" of isotope "tname(it)" 1143 1094 IF(is == 0) CYCLE 1144 lerr = ANY(reduceExpr(t% keys%val, vals)); IF(lerr) RETURN!--- Reduce expressions ; detect non-numerical elements1145 isot(iis)%keys(is)%key = t%key s%key1095 lerr = ANY(reduceExpr(t%val, vals)); IF(lerr) RETURN !--- Reduce expressions ; detect non-numerical elements 1096 isot(iis)%keys(is)%key = t%key 1146 1097 isot(iis)%keys(is)%val = vals 1147 1098 END DO 1148 1099 1149 1100 !--- CHECK FOR MISSING ISOTOPES (NO KEYS ALLOCATED) 1150 lerr = checkList(i sot(iis)%keys(:)%name, .NOT.[( ALLOCATED(isot(iis)%keys(is)%key), is=1, SIZE(isot(iis)%keys) )], &1101 lerr = checkList(iname, .NOT.[( ALLOCATED(isot(iis)%keys(is)%key), is=1, SIZE(isot(iis)%keys) )], & 1151 1102 'Check file "'//TRIM(fnam)//'" in section "'//TRIM(dBase(idb)%name)//'"', 'isotopes', 'missing') 1152 1103 IF(lerr) RETURN … … 1161 1112 1162 1113 !--- GET THE isoCheck ENTRY FROM THE *.DEF FILES (MIGHT BE CHANGED TO A CLASS-DEPENDANT KEYWORD) 1163 CALL get_in('ok_iso_verif', isot(strIdx(i sot%parent, 'H2O'))%check, .FALSE.)1114 CALL get_in('ok_iso_verif', isot(strIdx(iname, 'H2O'))%check, .FALSE.) 1164 1115 1165 1116 lerr = dispIsotopes() … … 1171 1122 INTEGER :: ik, nk, ip, it, nt 1172 1123 CHARACTER(LEN=maxlen) :: prf 1173 CHARACTER(LEN=maxlen), ALLOCATABLE :: ttl(:), val(:,:) 1124 CHARACTER(LEN=maxlen), ALLOCATABLE :: ttl(:), val(:,:), tname(:) 1174 1125 CALL msg('Isotopes parameters read from file "'//TRIM(fnam)//'":', modname) 1175 DO ip = 1, SIZE(isot) !--- Loop on parents tracers 1126 DO ip = 1, SIZE(isot) !--- Loop on isotopes classes 1127 IF(SIZE(isot(ip)%keys) == 0) CYCLE 1176 1128 nk = SIZE(isot(ip)%keys(1)%key) !--- Same keys for each isotope 1177 1129 nt = SIZE(isot(ip)%keys) !--- Number of isotopes … … 1179 1131 ALLOCATE(ttl(nk+2), val(nt,nk+1)) 1180 1132 ttl(1:2) = ['it ','name']; ttl(3:nk+2) = isot(ip)%keys(1)%key(:)!--- Titles line with keys names 1181 val(:,1) = isot(ip)%keys(:)%name !--- Values table 1st column: isotopes names 1133 lerr = getKey('name', tname, isot(ip)%keys); IF(lerr) RETURN 1134 val(:,1) = tname !--- Values table 1st column: isotopes names 1182 1135 DO ik = 1, nk 1183 1136 DO it = 1, nt … … 1199 1152 !=== IF ISOTOPES (2ND GENERATION TRACERS) ARE DETECTED: === 1200 1153 !=== * COMPUTE MOST OF THE RELATED QUANTITIES ("isot" COMPONENTS). === 1201 !=== * COMPUTE FEW ISOTOPES-DEDICATED "trac" COMPONENTS === 1202 !=== * CALL readIsotopesFile TO GET PHYSICAL QUANTITIES (<key>=<val> PAIRS) === 1203 !=== NOTE: THIS IS DONE HERE (IN A ROUTINE CALLED BY THE DYNAMIC), BECAUSE THE DYNAMIC NEEDS FEW PHYSICAL PARAMETERS. === 1204 !============================================================================================================================== 1205 LOGICAL FUNCTION processIsotopes(iNames) RESULT(lerr) 1206 CHARACTER(LEN=maxlen), TARGET, OPTIONAL, INTENT(IN) :: iNames(:) 1207 CHARACTER(LEN=maxlen), ALLOCATABLE :: p(:), str(:) !--- Temporary storage 1208 CHARACTER(LEN=maxlen), ALLOCATABLE :: tname(:), parent(:), dType(:), phase(:), gen0N(:) 1209 CHARACTER(LEN=maxlen) :: iName, modname 1210 CHARACTER(LEN=1) :: ph !--- Phase 1211 INTEGER, ALLOCATABLE :: iGen(:) 1212 INTEGER :: ic, ip, iq, it, iz 1213 LOGICAL, ALLOCATABLE :: ll(:) !--- Mask 1214 TYPE(trac_type), POINTER :: t(:), t1 1215 TYPE(isot_type), POINTER :: i 1154 !=== * COMPUTE FEW ISOTOPES-DEDICATED "trac" COMPONENTS (defined by "keys(:)") === 1155 !=== * CALL readIsotopesFile TO GET PHYSICAL QUANTITIES (<key>=<val> PAIRS) /!\ DISABLED FUNCTION /!\ === 1156 !============================================================================================================================== 1157 LOGICAL FUNCTION processIsotopes(keys, isot, iClasses) RESULT(lerr) 1158 TYPE(keys_type), TARGET, OPTIONAL, INTENT(INOUT) :: keys(:) 1159 TYPE(isot_type), TARGET, ALLOCATABLE, OPTIONAL, INTENT(OUT) :: isot(:) 1160 CHARACTER(LEN=*), TARGET, OPTIONAL, INTENT(IN) :: iClasses(:) 1161 CHARACTER(LEN=maxlen), ALLOCATABLE :: p(:), str1(:), str2(:) !--- Temporary storage 1162 CHARACTER(LEN=maxlen), ALLOCATABLE :: tname(:), parent(:), dType(:), phase(:), gen0N(:), iCla(:) 1163 CHARACTER(LEN=maxlen) :: iClass, modname 1164 CHARACTER(LEN=1) :: ph !--- Phase 1165 LOGICAL, ALLOCATABLE :: ll(:) !--- Mask 1166 INTEGER, ALLOCATABLE :: iGen(:) 1167 INTEGER :: ic, ip, iq, ii, it, iz 1168 TYPE(isot_type), POINTER :: i1 1169 TYPE(keys_type), POINTER :: k(:) 1216 1170 1217 1171 lerr = .FALSE. 1218 1172 modname = 'readIsotopesFile' 1219 1220 t => tracers 1221 1222 lerr = getKey('name', tname, t%keys); IF(lerr) RETURN !--- Names 1223 lerr = getKey('parent', parent, t%keys); IF(lerr) RETURN !--- Parents 1224 lerr = getKey('type', dType, t%keys); IF(lerr) RETURN !--- Tracer type 1225 lerr = getKey('phase', phase, t%keys); IF(lerr) RETURN !--- Phase 1226 lerr = getKey('gen0Name', gen0N, t%keys); IF(lerr) RETURN !--- 1st generation ancestor name 1227 lerr = getKey('iGeneration', iGen, t%keys); IF(lerr) RETURN !--- Generation number 1173 k => tracers; IF(PRESENT(keys )) k => keys 1174 lerr = getKey('name', tname, k); IF(lerr) RETURN !--- Names 1175 lerr = getKey('parent', parent, k); IF(lerr) RETURN !--- Parents 1176 lerr = getKey('type', dType, k); IF(lerr) RETURN !--- Tracer type 1177 lerr = getKey('phase', phase, k); IF(lerr) RETURN !--- Phase 1178 lerr = getKey('gen0Name', gen0N, k); IF(lerr) RETURN !--- 1st generation ancestor name 1179 lerr = getKey('iGeneration', iGen, k); IF(lerr) RETURN !--- Generation number 1180 1181 !--- INITIALIZATION IF ISOTOPES-SPECIFIC KEYS (MUST BE DEFINED EVEN WITHOUT ISOTOPES) 1182 DO iq = 1, SIZE(k) 1183 CALL addKey('iso_iGroup',0, k(iq)) !--- Family idx in list "isotopes(:)%parent" 1184 CALL addKey('iso_iName', 0, k(iq)) !--- Isotope idx in effective isotopes list 1185 CALL addKey('iso_iZone', 0, k(iq)) !--- Tagging zone idx in effective zones list 1186 CALL addKey('iso_iPhas', 0, k(iq)) !--- Phase idx in effective phases list 1187 END DO 1228 1188 1229 1189 !--- GET FROM "tracers" THE FULL LIST OF AVAILABLE ISOTOPES CLASSES 1230 p= PACK(delPhase(parent), MASK = dType=='tracer' .AND. iGen==1)1231 CALL strReduce( p, nbIso)1232 1233 !--- CHECK WHETHER NEEDED ISOTOPES CLASSES "i Names" ARE AVAILABLE OR NOT1234 IF(PRESENT(i Names)) THEN1235 DO it = 1, SIZE(i Names)1236 lerr = ALL( p /= iNames(it))1237 IF(fmsg('No isotopes class "'//TRIM(i Names(it))//'" found among tracers', modname, lerr)) RETURN1190 iCla = PACK(delPhase(parent), MASK = dType=='tracer' .AND. iGen==1) 1191 CALL strReduce(iCla) 1192 1193 !--- CHECK WHETHER NEEDED ISOTOPES CLASSES "iClasses" ARE AVAILABLE OR NOT 1194 IF(PRESENT(iClasses)) THEN 1195 DO it = 1, SIZE(iClasses) 1196 lerr = ALL(iCla /= iClasses(it)) 1197 IF(fmsg('No isotopes class "'//TRIM(iClasses(it))//'" found among tracers', modname, lerr)) RETURN 1238 1198 END DO 1239 p = iNames; nbIso = SIZE(p)1199 iCla = iClasses 1240 1200 END IF 1241 IF(ALLOCATED(isotopes)) DEALLOCATE(isotopes) 1242 ALLOCATE(isotopes(nbIso)) 1243 1201 nbIso = SIZE(iCla) 1202 1203 !--- USE THE ARGUMENT "isot" TO STORE THE ISOTOPIC DATABASE OR THE LOCAL VECTOR "isotopes" 1204 IF(PRESENT(isot)) THEN 1205 ALLOCATE( isot(nbIso)) 1206 ELSE 1207 IF(ALLOCATED(isotopes)) DEALLOCATE(isotopes) 1208 ALLOCATE(isotopes(nbIso)) 1209 END IF 1244 1210 IF(nbIso==0) RETURN !=== NO ISOTOPES: FINISHED 1245 1211 1246 1212 !--- ISOTOPES RELATED VARIABLES ; NULL OR EMPTY IF NO ISOTOPES 1247 isotopes(:)%parent = p 1248 DO ic = 1, SIZE(p) !--- Loop on isotopes classes 1249 i => isotopes(ic) 1250 iname = i%parent !--- Current isotopes class name (parent tracer name) 1251 1252 !=== Isotopes children of tracer "iname": mask, names, number (same for each phase of "iname") 1253 ll = dType=='tracer' .AND. delPhase(parent) == iname .AND. phase == 'g' 1254 str = PACK(delPhase(tname), MASK = ll) !--- Effectively found isotopes of "iname" 1255 i%niso = SIZE(str) !--- Number of "effectively found isotopes of "iname" 1256 ALLOCATE(i%keys(i%niso)) 1257 FORALL(it = 1:i%niso) i%keys(it)%name = str(it) 1258 1259 !=== Geographic tagging tracers descending on tracer "iname": mask, names, number 1260 ll = dType=='tag' .AND. delPhase(gen0N) == iname .AND. iGen == 2 1261 i%zone = PACK(strTail(tname,'_',.TRUE.), MASK = ll) !--- Tagging zones names for isotopes category "iname" 1262 CALL strReduce(i%zone) 1263 i%nzone = SIZE(i%zone) !--- Tagging zones number for isotopes category "iname" 1264 1265 !=== Geographic tracers of the isotopes children of tracer "iname" (same for each phase of "iname") 1213 DO ic = 1, nbIso !--- Loop on isotopes classes 1214 IF( PRESENT(isot)) i1 => isot (ic) 1215 IF(.NOT.PRESENT(isot)) i1 => isotopes(ic) 1216 iClass = iCla(ic) !--- Current isotopes class name (parent tracer name) 1217 i1%name = iClass 1218 1219 !=== Isotopes children of tracer "iClass": mask, names, number (same for each phase of "iClass") 1220 ll = dType=='tracer' .AND. delPhase(parent) == iClass .AND. phase == 'g' 1221 str1 = PACK(delPhase(tname), MASK = ll) !--- Effectively found isotopes of "iClass" 1222 i1%niso = SIZE(str1) !--- Number of "effectively found isotopes of "iname" 1223 ALLOCATE(i1%keys(i1%niso)) 1224 DO it = 1, i1%niso; CALL addKey('name', str1(it), i1%keys(it)); END DO 1225 1226 !=== Geographic tagging tracers descending on tracer "iClass": mask, names, number 1227 ll = dType=='tag' .AND. delPhase(gen0N) == iClass .AND. iGen == 2 1228 i1%zone = PACK(strTail(tname, '_', .TRUE.), MASK = ll) !--- Tagging zones names for isotopes category "iname" 1229 CALL strReduce(i1%zone) 1230 i1%nzone = SIZE(i1%zone) !--- Tagging zones number for isotopes category "iClass" 1231 1232 !=== Geographic tracers of the isotopes children of tracer "iClass" (same for each phase of "iClass") 1266 1233 ! NOTE: One might like to create a similar variable for 2nd generation tagging tracers (tagging the gen1 tracers) 1267 str = PACK(delPhase(tname), MASK=ll)1268 CALL strReduce(str )1269 i %ntiso = i%niso + SIZE(str)!--- Number of isotopes + their geographic tracers [ntiso]1270 ALLOCATE(i %trac(i%ntiso))1271 FORALL(it = 1:i%niso) i%trac(it) = i%keys(it)%name1272 FORALL(it = i%niso+1:i%ntiso) i%trac(it) = str(it-i%niso)1273 1274 !=== Phases for tracer "i name"1275 i %phase = ''1276 DO ip = 1, nphases; ph = known_phases(ip:ip); IF( strIdx(t%name,addPhase(iname, ph)) /= 0) i%phase = TRIM(i%phase)//ph; END DO1277 i %nphas = LEN_TRIM(i%phase) !--- Equal to "nqo" for water1234 str2 = PACK(delPhase(tname), MASK=ll) 1235 CALL strReduce(str2) 1236 i1%ntiso = i1%niso + SIZE(str2) !--- Number of isotopes + their geographic tracers [ntiso] 1237 ALLOCATE(i1%trac(i1%ntiso)) 1238 DO it = 1, i1%niso; i1%trac(it) = str1(it); END DO 1239 DO it = i1%niso+1, i1%ntiso; i1%trac(it) = str2(it-i1%niso); END DO 1240 1241 !=== Phases for tracer "iClass" 1242 i1%phase = '' 1243 DO ip = 1, nphases; ph = known_phases(ip:ip); IF(ANY(tname == addPhase(iClass, ph))) i1%phase = TRIM(i1%phase)//ph; END DO 1244 i1%nphas = LEN_TRIM(i1%phase) !--- Equal to "nqo" for water 1278 1245 1279 1246 !=== Tables giving the index in a table of effectively found items for each dynamical tracer (1<=iq<=nqtot) 1280 DO iq = 1, SIZE(t) 1281 t1 => tracers(iq) 1282 IF(delPhase(t1%gen0Name)/=iname .OR. t1%iGeneration==0) CYCLE !--- Only deal with tracers descending on "iname" 1283 t1%iso_iGroup = ic !--- Isotopes family idx in list "isotopes(:)%parent" 1284 t1%iso_iName = strIdx(i%trac, strHead(delPhase(t1%name),'_',.TRUE.)) !--- Current isotope idx in effective isotopes list 1285 t1%iso_iZone = strIdx(i%zone, strTail(t1%name, '_',.TRUE.)) !--- Current isotope zone idx in effective zones list 1286 t1%iso_iPhase = INDEX(i%phase,TRIM(t1%phase)) !--- Current isotope phase idx in effective phases list 1287 IF(t1%iGeneration /= 2) t1%iso_iZone = 0 !--- Skip possible generation 1 tagging tracers 1247 DO iq = 1, SIZE(tracers) 1248 ii = strIdx(i1%trac, strHead(delPhase(tname(iq)), '_', .TRUE.)) 1249 iz = strIdx(i1%zone, strTail( tname(iq), '_', .TRUE.)) 1250 ip = INDEX(i1%phase, TRIM(phase(iq) )) 1251 IF(delPhase(gen0N(iq)) /= iClass .OR. iGen(iq) == 0) CYCLE !--- Only deal with tracers descending on "iClass" 1252 CALL addKey('iso_iGroup',ic, k(iq)) !--- Family idx in list "isotopes(:)%name" 1253 CALL addKey('iso_iName', ii, k(iq)) !--- Isotope idx in effective isotopes list 1254 CALL addKey('iso_iZone', iz, k(iq)) !--- Tagging zone idx in effective zones list 1255 CALL addKey('iso_iPhas', ip, k(iq)) !--- Phase idx in effective phases list 1256 IF(iGen(iq) /= 2) CALL addKey('iso_iZone', 0, k(iq)) !--- Skip possible generation 1 tagging tracers 1288 1257 END DO 1289 1258 1290 1259 !=== Table used to get iq (index in dyn array, size nqtot) from the isotope and phase indexes ; the full isotopes list 1291 1260 ! (including tagging tracers) is sorted this way: iso1, iso2, ..., iso1_zone1, iso2_zone1, ..., iso1_zoneN, iso2_zoneN 1292 i %iqIsoPha = RESHAPE( [( (strIdx(t%name, addPhase(i%trac(it),i%phase(ip:ip))), it=1, i%ntiso), ip=1, i%nphas)], &1293 [i %ntiso, i%nphas] )1261 i1%iqIsoPha = RESHAPE( [( (strIdx(tname, addPhase(i1%trac(it),i1%phase(ip:ip))), it=1, i1%ntiso), ip=1, i1%nphas)], & 1262 [i1%ntiso, i1%nphas] ) 1294 1263 !=== Table used to get iq (index in dyn array, size nqtot) from the water and isotope and phase indexes ; the full isotopes list 1295 1264 ! (including tagging tracers) is sorted this way: iso1, iso2, ..., iso1_zone1, iso2_zone1, ..., iso1_zoneN, iso2_zoneN 1296 i %iqWIsoPha = RESHAPE( [( [strIdx(t%name, addPhase('H2O',i%phase(ip:ip))), i%iqIsoPha(:,ip)], ip=1,i%nphas)], &1297 [1+i %ntiso, i%nphas] )1265 i1%iqWIsoPha = RESHAPE( [( [strIdx(tname, addPhase('H2O', i1%phase(ip:ip))), i1%iqIsoPha(:,ip)], ip=1, i1%nphas)], & 1266 [1+i1%ntiso, i1%nphas] ) 1298 1267 !=== Table used to get ix (index in tagging tracers isotopes list, size ntiso) from the zone and isotope indexes 1299 i %itZonIso = RESHAPE( [( (strIdx(i%trac(:), TRIM(i%trac(it))//'_'//TRIM(i%zone(iz))), iz=1, i%nzone), it=1, i%niso )], &1300 [i %nzone, i%niso] )1268 i1%itZonIso = RESHAPE( [( (strIdx(i1%trac(:), TRIM(i1%trac(it))//'_'//TRIM(i1%zone(iz))), iz=1, i1%nzone), it=1, i1%niso )], & 1269 [i1%nzone, i1%niso] ) 1301 1270 END DO 1302 1271 1303 !=== READ PHYSICAL PARAMETERS FROM isoFile FILE 1304 ! lerr = readIsotopesFile(isoFile, isotopes); IF(lerr) RETURN! on commente pour ne pas chercher isotopes_params.def 1272 !=== READ PHYSICAL PARAMETERS FROM isoFile FILE (COMMENTED => DISABLED) 1273 ! IF( PRESENT(isot)) lerr = readIsotopesFile(isoFile, isot) 1274 ! IF(.NOT.PRESENT(isot)) lerr = readIsotopesFile(isoFile, isotopes) 1275 ! IF(lerr) RETURN 1305 1276 1306 1277 !--- GET THE isoCheck ENTRY FROM THE *.DEF FILES (MIGHT BE CHANGED TO A CLASS-DEPENDANT KEYWORD) … … 1311 1282 1312 1283 !=== SELECT WATER ISOTOPES CLASS OR, IF UNFOUND, THE FIRST ISOTOPES CLASS 1313 IF(isoSelect('H2O', .TRUE.)) THEN; iH2O = ixIso; ELSE; lerr = isoSelect(1, .TRUE.); END IF 1284 IF(isoSelect('H2O', lVerbose=.TRUE.)) THEN 1285 iH2O = ixIso 1286 ELSE 1287 lerr = isoSelect(1, lVerbose=.TRUE.) 1288 END IF 1314 1289 1315 1290 CONTAINS … … 1319 1294 !------------------------------------------------------------------------------------------------------------------------------ 1320 1295 INTEGER :: ix, it, ip, np, iz, nz, npha, nzon 1321 TYPE(isot_type), POINTER :: i1322 1296 DO ix = 1, nbIso 1323 i => isotopes(ix) 1297 IF( PRESENT(isot)) i1 => isot (ix) 1298 IF(.NOT.PRESENT(isot)) i1 => isotopes(ix) 1324 1299 !--- Check whether each isotope and tagging isotopic tracer is present in the same number of phases 1325 DO it = 1, i %ntiso; npha = i%nphas1326 np = SUM([(COUNT(t racers(:)%name == addPhase(i%trac(it), i%phase(ip:ip))), ip=1, npha)])1300 DO it = 1, i1%ntiso; npha = i1%nphas 1301 np = SUM([(COUNT(tname(:) == addPhase(i1%trac(it), i1%phase(ip:ip))), ip=1, npha)]) 1327 1302 lerr = np /= npha 1328 CALL msg(TRIM(int2str(np))// ' phases instead of '//TRIM(int2str(npha))//' for '//TRIM(i%trac(it)), modname, lerr)1303 CALL msg(TRIM(int2str(np))// ' phases instead of '//TRIM(int2str(npha))//' for '//TRIM(i1%trac(it)), modname, lerr) 1329 1304 IF(lerr) RETURN 1330 1305 END DO 1331 DO it = 1, i %niso; nzon = i%nzone1332 nz = SUM([(COUNT(i %trac == TRIM(i%trac(it))//'_'//i%zone(iz)), iz=1, nzon)])1306 DO it = 1, i1%niso; nzon = i1%nzone 1307 nz = SUM([(COUNT(i1%trac == TRIM(i1%trac(it))//'_'//i1%zone(iz)), iz=1, nzon)]) 1333 1308 lerr = nz /= nzon 1334 CALL msg(TRIM(int2str(nz))//' tagging zones instead of '//TRIM(int2str(nzon))//' for '//TRIM(i %trac(it)), modname, lerr)1309 CALL msg(TRIM(int2str(nz))//' tagging zones instead of '//TRIM(int2str(nzon))//' for '//TRIM(i1%trac(it)), modname, lerr) 1335 1310 IF(lerr) RETURN 1336 1311 END DO … … 1345 1320 !============================================================================================================================== 1346 1321 !=== THE ROUTINE isoSelect IS USED TO SWITCH FROM AN ISOTOPE FAMILY TO ANOTHER: ISOTOPES DEPENDENT PARAMETERS ARE UPDATED 1347 ! Single generic "isoSelect" routine, using the predefined index of the parent(fast version) or its name (first call).1348 !============================================================================================================================== 1349 LOGICAL FUNCTION isoSelectByName(i Name, lVerbose) RESULT(lerr)1322 ! Single generic "isoSelect" routine, using the predefined index of the class (fast version) or its name (first call). 1323 !============================================================================================================================== 1324 LOGICAL FUNCTION isoSelectByName(iClass, isot, lVerbose) RESULT(lerr) 1350 1325 IMPLICIT NONE 1351 CHARACTER(LEN=*), INTENT(IN) :: iName 1352 LOGICAL, OPTIONAL, INTENT(IN) :: lVerbose 1326 CHARACTER(LEN=*), INTENT(IN) :: iClass 1327 TYPE(isot_type), OPTIONAL, TARGET, INTENT(IN) :: isot(:) 1328 LOGICAL, OPTIONAL, INTENT(IN) :: lVerbose 1329 TYPE(isot_type), POINTER :: iso(:) 1353 1330 INTEGER :: iIso 1354 1331 LOGICAL :: lV 1355 lV = .FALSE.; IF(PRESENT(lVerbose)) lV = lVerbose 1356 iIso = strIdx(isotopes(:)%parent, iName) 1332 lV = .FALSE.; IF(PRESENT(lVerbose)) lV = lVerbose 1333 iso => isotopes; IF(PRESENT(isot)) iso => isot 1334 iIso = strIdx(iso(:)%name, iClass) 1357 1335 lerr = iIso == 0 1358 1336 IF(lerr) THEN 1359 1337 niso = 0; ntiso = 0; nzone = 0; nphas = 0; isoCheck=.FALSE. 1360 CALL msg('no isotope family named "'//TRIM(i Name)//'"', ll=lV)1338 CALL msg('no isotope family named "'//TRIM(iClass)//'"', ll=lV) 1361 1339 RETURN 1362 1340 END IF 1363 lerr = isoSelectByIndex(iIso, lV)1341 lerr = isoSelectByIndex(iIso, iso, lV) 1364 1342 END FUNCTION isoSelectByName 1365 1343 !============================================================================================================================== 1366 LOGICAL FUNCTION isoSelectByIndex(iIso, lVerbose) RESULT(lerr)1344 LOGICAL FUNCTION isoSelectByIndex(iIso, isot, lVerbose) RESULT(lerr) 1367 1345 IMPLICIT NONE 1368 INTEGER, INTENT(IN) :: iIso 1369 LOGICAL, OPTIONAL, INTENT(IN) :: lVerbose 1346 INTEGER, INTENT(IN) :: iIso 1347 TYPE(isot_type), TARGET, OPTIONAL, INTENT(INOUT) :: isot(:) 1348 LOGICAL, OPTIONAL, INTENT(IN) :: lVerbose 1349 TYPE(isot_type), POINTER :: i(:) 1370 1350 LOGICAL :: lV 1371 lv = .FALSE.; IF(PRESENT(lVerbose)) lv = lVerbose 1351 lV = .FALSE.; IF(PRESENT(lVerbose)) lV = lVerbose 1352 i => isotopes; IF(PRESENT(isot)) i => isot 1372 1353 lerr = .FALSE. 1373 1354 IF(iIso == ixIso) RETURN !--- Nothing to do if the index is already OK 1374 lerr = iIso<=0 .OR. iIso>SIZE(i sotopes)1355 lerr = iIso<=0 .OR. iIso>SIZE(i) 1375 1356 CALL msg('Inconsistent isotopes family index '//TRIM(int2str(iIso))//': should be > 0 and <= '& 1376 //TRIM(int2str(SIZE(i sotopes)))//'"', ll = lerr .AND. lV)1357 //TRIM(int2str(SIZE(i)))//'"', ll = lerr .AND. lV) 1377 1358 IF(lerr) RETURN 1378 1359 ixIso = iIso !--- Update currently selected family index 1379 isotope => i sotopes(ixIso)!--- Select corresponding component1360 isotope => i(ixIso) !--- Select corresponding component 1380 1361 isoKeys => isotope%keys; niso = isotope%niso 1381 1362 isoName => isotope%trac; ntiso = isotope%ntiso … … 1384 1365 itZonIso => isotope%itZonIso; isoCheck = isotope%check 1385 1366 iqIsoPha => isotope%iqIsoPha 1386 iqWIsoPha 1367 iqWIsoPha=> isotope%iqWIsoPha 1387 1368 END FUNCTION isoSelectByIndex 1388 1369 !============================================================================================================================== … … 1528 1509 !=== OVERWRITE THE KEYS OF THE TRACER NAMED "tr0" WITH THE VALUES FOUND IN THE *.def FILES, IF ANY. =========================== 1529 1510 !============================================================================================================================== 1530 SUBROUTINE addKeysFromDef(t, tr0)1531 TYPE( trac_type), ALLOCATABLE, INTENT(INOUT) :: t(:)1511 LOGICAL FUNCTION addKeysFromDef(t, tr0) RESULT(lerr) 1512 TYPE(keys_type), ALLOCATABLE, INTENT(INOUT) :: t(:) 1532 1513 CHARACTER(LEN=*), INTENT(IN) :: tr0 1533 1514 !------------------------------------------------------------------------------------------------------------------------------ 1515 CHARACTER(LEN=maxlen), ALLOCATABLE :: tname(:) 1534 1516 CHARACTER(LEN=maxlen) :: val 1535 1517 INTEGER :: ik, jd 1536 jd = strIdx(t%name, tr0) 1518 lerr = getKey('name', tname, t); IF(lerr) RETURN 1519 jd = strIdx(tname(:), tr0) 1537 1520 IF(jd == 0) RETURN 1538 DO ik = 1, SIZE(t(jd)%key s%key)1539 CALL get_in(t(jd)%key s%key(ik), val, '*none*')1540 IF(val /= '*none*') CALL addKey(t(jd)%key s%key(ik), val, t(jd)%keys, .TRUE.)1521 DO ik = 1, SIZE(t(jd)%key) 1522 CALL get_in(t(jd)%key(ik), val, '*none*') 1523 IF(val /= '*none*') CALL addKey(t(jd)%key(ik), val, t(jd), .TRUE.) 1541 1524 END DO 1542 END SUBROUTINEaddKeysFromDef1525 END FUNCTION addKeysFromDef 1543 1526 !============================================================================================================================== 1544 1527 … … 1550 1533 INTEGER, INTENT(IN) :: itr 1551 1534 CHARACTER(LEN=*), INTENT(IN) :: keyn(:) 1552 TYPE( trac_type), INTENT(INOUT) :: ky(:)1535 TYPE(keys_type), INTENT(INOUT) :: ky(:) 1553 1536 !------------------------------------------------------------------------------------------------------------------------------ 1554 1537 CHARACTER(LEN=maxlen), ALLOCATABLE :: k(:), v(:) … … 1556 1539 INTEGER :: iky 1557 1540 IF(itr<=0 .OR. itr>SIZE(ky, DIM=1)) RETURN !--- Index is out of range 1558 ll = [( ALL(keyn/=ky(itr)%key s%key(iky)), iky=1, SIZE(ky(itr)%keys%key) )]1559 k = PACK(ky(itr)%key s%key, MASK=ll); CALL MOVE_ALLOC(FROM=k, TO=ky(itr)%keys%key)1560 v = PACK(ky(itr)% keys%val, MASK=ll); CALL MOVE_ALLOC(FROM=v, TO=ky(itr)%keys%val)1541 ll = [( ALL(keyn/=ky(itr)%key(iky)), iky=1, SIZE(ky(itr)%key) )] 1542 k = PACK(ky(itr)%key, MASK=ll); CALL MOVE_ALLOC(FROM=k, TO=ky(itr)%key) 1543 v = PACK(ky(itr)%val, MASK=ll); CALL MOVE_ALLOC(FROM=v, TO=ky(itr)%val) 1561 1544 END SUBROUTINE delKey_1 1562 1545 !============================================================================================================================== 1563 1546 SUBROUTINE delKey(keyn, ky) 1564 1547 CHARACTER(LEN=*), INTENT(IN) :: keyn(:) 1565 TYPE( trac_type), INTENT(INOUT) :: ky(:)1548 TYPE(keys_type), INTENT(INOUT) :: ky(:) 1566 1549 !------------------------------------------------------------------------------------------------------------------------------ 1567 1550 INTEGER :: iky … … 1611 1594 !=== TRY TO GET THE KEY NAMED "key" FOR THE "itr"th TRACER IN: === 1612 1595 !=== * ARGUMENT "ky" DATABASE IF SPECIFIED ; OTHERWISE: === 1613 !=== * IN INTERNAL TRACERS DATABASE "tracers(:) %keys" (IF UNFOUND, IN INTERNAL ISOTOPES DATABASE "isotope%keys(:)")===1596 !=== * IN INTERNAL TRACERS DATABASE "tracers(:)" (IF UNFOUND, IN INTERNAL ISOTOPES DATABASE "isotope%keys(:)") === 1614 1597 !=== THE RETURNED VALUE (STRING, AN INTEGER, A REAL OR A LOGICAL) CAN BE EITHER: === 1615 1598 !=== * A SCALAR === … … 1677 1660 lerr = .TRUE. 1678 1661 IF(lerr .AND. PRESENT(ky)) val = fgetKey(ky) !--- "ky" 1679 IF(lerr .AND. ALLOCATED (tracers)) val = fgetKey(tracers(:) %keys)!--- "tracers"1662 IF(lerr .AND. ALLOCATED (tracers)) val = fgetKey(tracers(:)) !--- "tracers" 1680 1663 IF(lerr .AND. ASSOCIATED(isotope)) val = fgetKey(isotope%keys(:)) !--- "isotope" 1681 1664 IF(lerr .AND. PRESENT(def)) THEN … … 1782 1765 IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN 1783 1766 val = str2int(svals) 1784 lerr = ANY(val == -HUGE(1)) 1767 lerr = ANY(val == -HUGE(1)) .AND. sval /= '' 1785 1768 s = 'key "'//TRIM(keyn)//'" of tracer nr. '//TRIM(int2str(itr))//' is not' 1786 1769 CALL msg(TRIM(s)//' an integer: '//TRIM(sval), modname, lerr) … … 1802 1785 IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN 1803 1786 val = str2real(svals) 1804 lerr = ANY(val == -HUGE(1.)) 1787 lerr = ANY(val == -HUGE(1.)) .AND. sval /= '' 1805 1788 s = 'key "'//TRIM(keyn)//'" of tracer nr. '//TRIM(int2str(itr))//' is not' 1806 1789 CALL msg(TRIM(s)//' a real: '//TRIM(sval), modname, lerr) … … 1823 1806 IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN 1824 1807 ivals = str2bool(svals) 1825 lerr = ANY(ivals == -1) 1808 lerr = ANY(ivals == -1) .AND. sval /= '' 1826 1809 s = 'key "'//TRIM(keyn)//'" of tracer nr. '//TRIM(int2str(itr))//' is not' 1827 1810 CALL msg(TRIM(s)//' a boolean: '//TRIM(sval), modname, lerr) … … 1860 1843 IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN 1861 1844 val = str2int(svals) 1862 lerr = ANY(val == -HUGE(1)) 1845 lerr = ANY(val == -HUGE(1)) .AND. sval /= '' 1863 1846 s = 'key "'//TRIM(strStack(keyn, '/'))//'" of tracer nr. '//TRIM(int2str(itr))//' is not' 1864 1847 CALL msg(TRIM(s)//' an integer: '//TRIM(sval), modname, lerr) … … 1881 1864 IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN 1882 1865 val = str2real(svals) 1883 lerr = ANY(val == -HUGE(1.)) 1866 lerr = ANY(val == -HUGE(1.)) .AND. sval /= '' 1884 1867 s = 'key "'//TRIM(strStack(keyn, '/'))//'" of tracer nr. '//TRIM(int2str(itr))//' is not' 1885 1868 CALL msg(TRIM(s)//' a real: '//TRIM(sval), modname, lerr) … … 1903 1886 IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN 1904 1887 ivals = str2bool(svals) 1905 lerr = ANY(ivals == -1) 1888 lerr = ANY(ivals == -1) .AND. sval /= '' 1906 1889 s = 'key "'//TRIM(strStack(keyn, '/'))//'" of tracer nr. '//TRIM(int2str(itr))//' is not' 1907 1890 CALL msg(TRIM(s)//' a boolean: '//TRIM(sval), modname, lerr) … … 1910 1893 !============================================================================================================================== 1911 1894 !============================================================================================================================== 1912 LOGICAL FUNCTION getKeyByIndex_s1mm(keyn, val, ky, nam, def, lDisp) RESULT(lerr) 1913 CHARACTER(LEN=*), INTENT(IN) :: keyn 1914 CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: val(:) 1915 TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) 1916 CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:) 1917 CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: def 1918 LOGICAL, OPTIONAL, INTENT(IN) :: lDisp 1919 lerr = getKeyByIndex_smmm([keyn], val, ky, nam, def, lDisp) 1895 LOGICAL FUNCTION getKeyByIndex_s1mm(keyn, val, ky, def, lDisp) RESULT(lerr) 1896 CHARACTER(LEN=*), INTENT(IN) :: keyn 1897 CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: val(:) 1898 TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) 1899 CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: def 1900 LOGICAL, OPTIONAL, INTENT(IN) :: lDisp 1901 lerr = getKeyByIndex_smmm([keyn], val, ky, def, lDisp) 1920 1902 END FUNCTION getKeyByIndex_s1mm 1921 1903 !============================================================================================================================== 1922 LOGICAL FUNCTION getKeyByIndex_i1mm(keyn, val, ky, nam, def, lDisp) RESULT(lerr) 1923 CHARACTER(LEN=*), INTENT(IN) :: keyn 1924 INTEGER, ALLOCATABLE, INTENT(OUT) :: val(:) 1925 TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) 1926 CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:) 1927 INTEGER, OPTIONAL, INTENT(IN) :: def 1928 LOGICAL, OPTIONAL, INTENT(IN) :: lDisp 1929 lerr = getKeyByIndex_immm([keyn], val, ky, nam, def, lDisp) 1904 LOGICAL FUNCTION getKeyByIndex_i1mm(keyn, val, ky, def, lDisp) RESULT(lerr) 1905 CHARACTER(LEN=*), INTENT(IN) :: keyn 1906 INTEGER, ALLOCATABLE, INTENT(OUT) :: val(:) 1907 TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) 1908 INTEGER, OPTIONAL, INTENT(IN) :: def 1909 LOGICAL, OPTIONAL, INTENT(IN) :: lDisp 1910 lerr = getKeyByIndex_immm([keyn], val, ky, def, lDisp) 1930 1911 END FUNCTION getKeyByIndex_i1mm 1931 1912 !============================================================================================================================== 1932 LOGICAL FUNCTION getKeyByIndex_r1mm(keyn, val, ky, nam, def, lDisp) RESULT(lerr) 1933 CHARACTER(LEN=*), INTENT(IN) :: keyn 1934 REAL, ALLOCATABLE, INTENT(OUT) :: val(:) 1935 TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) 1936 CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:) 1937 REAL, OPTIONAL, INTENT(IN) :: def 1938 LOGICAL, OPTIONAL, INTENT(IN) :: lDisp 1939 lerr = getKeyByIndex_rmmm([keyn], val, ky, nam, def, lDisp) 1913 LOGICAL FUNCTION getKeyByIndex_r1mm(keyn, val, ky, def, lDisp) RESULT(lerr) 1914 CHARACTER(LEN=*), INTENT(IN) :: keyn 1915 REAL, ALLOCATABLE, INTENT(OUT) :: val(:) 1916 TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) 1917 REAL, OPTIONAL, INTENT(IN) :: def 1918 LOGICAL, OPTIONAL, INTENT(IN) :: lDisp 1919 lerr = getKeyByIndex_rmmm([keyn], val, ky, def, lDisp) 1940 1920 END FUNCTION getKeyByIndex_r1mm 1941 1921 !============================================================================================================================== 1942 LOGICAL FUNCTION getKeyByIndex_l1mm(keyn, val, ky, nam, def, lDisp) RESULT(lerr) 1943 CHARACTER(LEN=*), INTENT(IN) :: keyn 1944 LOGICAL, ALLOCATABLE, INTENT(OUT) :: val(:) 1945 TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) 1946 CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:) 1947 LOGICAL, OPTIONAL, INTENT(IN) :: def 1948 LOGICAL, OPTIONAL, INTENT(IN) :: lDisp 1949 lerr = getKeyByIndex_lmmm([keyn], val, ky, nam, def, lDisp) 1922 LOGICAL FUNCTION getKeyByIndex_l1mm(keyn, val, ky, def, lDisp) RESULT(lerr) 1923 CHARACTER(LEN=*), INTENT(IN) :: keyn 1924 LOGICAL, ALLOCATABLE, INTENT(OUT) :: val(:) 1925 TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) 1926 LOGICAL, OPTIONAL, INTENT(IN) :: def 1927 LOGICAL, OPTIONAL, INTENT(IN) :: lDisp 1928 lerr = getKeyByIndex_lmmm([keyn], val, ky, def, lDisp) 1950 1929 END FUNCTION getKeyByIndex_l1mm 1951 1930 !============================================================================================================================== 1952 1931 !============================================================================================================================== 1953 LOGICAL FUNCTION getKeyByIndex_smmm(keyn, val, ky, nam, def, lDisp) RESULT(lerr) 1954 CHARACTER(LEN=*), INTENT(IN) :: keyn(:) 1955 CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: val(:) 1956 TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) 1957 CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:) 1958 CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: def 1959 LOGICAL, OPTIONAL, INTENT(IN) :: lDisp 1932 LOGICAL FUNCTION getKeyByIndex_smmm(keyn, val, ky, def, lDisp) RESULT(lerr) 1933 CHARACTER(LEN=*), INTENT(IN) :: keyn(:) 1934 CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: val(:) 1935 TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) 1936 CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: def 1937 LOGICAL, OPTIONAL, INTENT(IN) :: lDisp 1960 1938 !------------------------------------------------------------------------------------------------------------------------------ 1961 1939 CHARACTER(LEN=maxlen) :: s 1962 CHARACTER(LEN=maxlen), ALLOCATABLE :: tname(:)1963 1940 INTEGER :: iq, nq(3), k 1964 1941 LOGICAL :: lD, l(3) … … 1967 1944 lerr = .TRUE. 1968 1945 IF(PRESENT(ky)) THEN; val = fgetKey(ky) !--- "ky" 1969 ELSE IF(ALLOCATED(tracers)) THEN; val = fgetKey(tracers(:) %keys)!--- "tracers"1946 ELSE IF(ALLOCATED(tracers)) THEN; val = fgetKey(tracers(:)) !--- "tracers" 1970 1947 IF(lerr .AND. ASSOCIATED(isotope)) val = fgetKey(isotope%keys(:)) !--- "isotope" 1971 1948 END IF 1972 IF(.NOT.lerr) THEN; IF(PRESENT(nam)) nam = tname; RETURN; END IF1949 IF(.NOT.lerr) RETURN 1973 1950 IF(.NOT.PRESENT(def)) THEN; CALL msg('No '//TRIM(s)//' found', modname, lD); RETURN; END IF 1974 1951 … … 1991 1968 INTEGER :: iq 1992 1969 lerr = SIZE(ky) == 0; IF(lerr) RETURN 1993 tname = ky%name1994 1970 val = [(fgetKeyIdx(iq, keyn(:), ky, ler(iq)), iq = 1, SIZE(ky))] 1995 1971 lerr = ANY(ler) … … 1998 1974 END FUNCTION getKeyByIndex_smmm 1999 1975 !============================================================================================================================== 2000 LOGICAL FUNCTION getKeyByIndex_immm(keyn, val, ky, nam, def, lDisp) RESULT(lerr) 2001 CHARACTER(LEN=*), INTENT(IN) :: keyn(:) 2002 INTEGER, ALLOCATABLE, INTENT(OUT) :: val(:) 2003 TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) 2004 CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:) 2005 INTEGER, OPTIONAL, INTENT(IN) :: def 2006 LOGICAL, OPTIONAL, INTENT(IN) :: lDisp 1976 LOGICAL FUNCTION getKeyByIndex_immm(keyn, val, ky, def, lDisp) RESULT(lerr) 1977 CHARACTER(LEN=*), INTENT(IN) :: keyn(:) 1978 INTEGER, ALLOCATABLE, INTENT(OUT) :: val(:) 1979 TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) 1980 INTEGER, OPTIONAL, INTENT(IN) :: def 1981 LOGICAL, OPTIONAL, INTENT(IN) :: lDisp 2007 1982 !------------------------------------------------------------------------------------------------------------------------------ 2008 1983 CHARACTER(LEN=maxlen) :: s 2009 1984 CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:), tname(:) 2010 1985 LOGICAL, ALLOCATABLE :: ll(:) 2011 IF( PRESENT(def)) lerr = getKeyByIndex_smmm(keyn, svals, ky, tname,int2str(def), lDisp)2012 IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_smmm(keyn, svals, ky, tname,lDisp=lDisp)1986 IF( PRESENT(def)) lerr = getKeyByIndex_smmm(keyn, svals, ky, int2str(def), lDisp) 1987 IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_smmm(keyn, svals, ky, lDisp=lDisp) 2013 1988 IF(lerr) RETURN 2014 1989 val = str2int(svals) 2015 ll = val == -HUGE(1) 2016 lerr = ANY(ll); IF(.NOT.lerr) THEN; IF(PRESENT(nam)) nam = tname; RETURN; END IF 1990 ll = val == -HUGE(1) .AND. (SIZE(svals) /=1 .OR. svals(1) /= '') 1991 lerr = ANY(ll); IF(.NOT.lerr) RETURN 1992 IF(getKeyByIndex_smmm(['name'], tname, ky)) RETURN 2017 1993 s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(strStack(PACK(tname, MASK=ll)))//' is not' 2018 1994 CALL msg(TRIM(s)//' an integer: '//TRIM(strStack(svals, MASK=ll)), modname, lerr) 2019 IF(.NOT.lerr .AND. PRESENT(nam)) nam = tname2020 1995 END FUNCTION getKeyByIndex_immm 2021 1996 !============================================================================================================================== 2022 LOGICAL FUNCTION getKeyByIndex_rmmm(keyn, val, ky, nam, def, lDisp) RESULT(lerr) 2023 CHARACTER(LEN=*), INTENT(IN) :: keyn(:) 2024 REAL, ALLOCATABLE, INTENT(OUT) :: val(:) 2025 TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) 2026 CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:) 2027 REAL, OPTIONAL, INTENT(IN) :: def 2028 LOGICAL, OPTIONAL, INTENT(IN) :: lDisp 1997 LOGICAL FUNCTION getKeyByIndex_rmmm(keyn, val, ky, def, lDisp) RESULT(lerr) 1998 CHARACTER(LEN=*), INTENT(IN) :: keyn(:) 1999 REAL, ALLOCATABLE, INTENT(OUT) :: val(:) 2000 TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) 2001 REAL, OPTIONAL, INTENT(IN) :: def 2002 LOGICAL, OPTIONAL, INTENT(IN) :: lDisp 2029 2003 !------------------------------------------------------------------------------------------------------------------------------ 2030 2004 CHARACTER(LEN=maxlen) :: s 2031 2005 CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:), tname(:) 2032 2006 LOGICAL, ALLOCATABLE :: ll(:) 2033 IF( PRESENT(def)) lerr = getKeyByIndex_smmm(keyn, svals, ky, tname,real2str(def), lDisp)2034 IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_smmm(keyn, svals, ky, tname,lDisp=lDisp)2007 IF( PRESENT(def)) lerr = getKeyByIndex_smmm(keyn, svals, ky, real2str(def), lDisp) 2008 IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_smmm(keyn, svals, ky, lDisp=lDisp) 2035 2009 IF(lerr) RETURN 2036 2010 val = str2real(svals) 2037 ll = val == -HUGE(1.) 2038 lerr = ANY(ll); IF(.NOT.lerr) THEN; IF(PRESENT(nam)) nam = tname; RETURN; END IF 2011 ll = val == -HUGE(1.) .AND. (SIZE(svals) /=1 .OR. svals(1) /= '') 2012 lerr = ANY(ll); IF(.NOT.lerr) RETURN 2013 IF(getKeyByIndex_smmm(['name'], tname, ky)) RETURN 2039 2014 s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(strStack(PACK(tname, MASK=ll)))//' is not a' 2040 2015 CALL msg(TRIM(s)//' a real: '//TRIM(strStack(svals, MASK=ll)), modname) 2041 2016 END FUNCTION getKeyByIndex_rmmm 2042 2017 !============================================================================================================================== 2043 LOGICAL FUNCTION getKeyByIndex_lmmm(keyn, val, ky, nam, def, lDisp) RESULT(lerr) 2044 CHARACTER(LEN=*), INTENT(IN) :: keyn(:) 2045 LOGICAL, ALLOCATABLE, INTENT(OUT) :: val(:) 2046 TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) 2047 CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:) 2048 LOGICAL, OPTIONAL, INTENT(IN) :: def 2049 LOGICAL, OPTIONAL, INTENT(IN) :: lDisp 2018 LOGICAL FUNCTION getKeyByIndex_lmmm(keyn, val, ky, def, lDisp) RESULT(lerr) 2019 CHARACTER(LEN=*), INTENT(IN) :: keyn(:) 2020 LOGICAL, ALLOCATABLE, INTENT(OUT) :: val(:) 2021 TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) 2022 LOGICAL, OPTIONAL, INTENT(IN) :: def 2023 LOGICAL, OPTIONAL, INTENT(IN) :: lDisp 2050 2024 !------------------------------------------------------------------------------------------------------------------------------ 2051 2025 CHARACTER(LEN=maxlen) :: s … … 2053 2027 LOGICAL, ALLOCATABLE :: ll(:) 2054 2028 INTEGER, ALLOCATABLE :: ivals(:) 2055 IF( PRESENT(def)) lerr = getKeyByIndex_smmm(keyn, svals, ky, tname,bool2str(def), lDisp)2056 IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_smmm(keyn, svals, ky, tname,lDisp=lDisp)2029 IF( PRESENT(def)) lerr = getKeyByIndex_smmm(keyn, svals, ky, bool2str(def), lDisp) 2030 IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_smmm(keyn, svals, ky, lDisp=lDisp) 2057 2031 IF(lerr) RETURN 2058 2032 ivals = str2bool(svals) 2059 ll = ivals == -1 2060 lerr = ANY(ll); IF(.NOT.lerr) THEN; val = ivals == 1; IF(PRESENT(nam)) nam = tname; RETURN; END IF 2033 ll = ivals == -1 .AND. (SIZE(svals) /=1 .OR. svals(1) /= '') 2034 lerr = ANY(ll); IF(.NOT.lerr) RETURN 2035 IF(getKeyByIndex_smmm(['name'], tname, ky)) RETURN 2061 2036 s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(strStack(tname, MASK=ll))//' is not' 2062 2037 CALL msg(TRIM(s)//' a boolean: '//TRIM(strStack(svals, MASK=ll)), modname) … … 2071 2046 !=== TRY TO GET THE KEY NAMED "key" FOR THE TRACER NAMED "tname" IN: === 2072 2047 !=== * ARGUMENT "ky" DATABASE IF SPECIFIED ; OTHERWISE: === 2073 !=== * IN INTERNAL TRACERS DATABASE "tracers(:) %keys" (IF UNFOUND, IN INTERNAL ISOTOPES DATABASE "isotope%keys(:)")===2048 !=== * IN INTERNAL TRACERS DATABASE "tracers(:)" (IF UNFOUND, IN INTERNAL ISOTOPES DATABASE "isotope%keys(:)") === 2074 2049 !=== THE RETURNED VALUE (STRING, AN INTEGER, A REAL OR A LOGICAL) CAN BE EITHER: === 2075 2050 !=== * A SCALAR === … … 2133 2108 tnam = strHead(delPhase(tname),'_',.TRUE.) !--- Remove phase and tag 2134 2109 IF(lerr .AND. PRESENT(ky)) val = fgetKey(ky) !--- "ky" 2135 IF(lerr .AND. ALLOCATED (tracers)) val = fgetKey(tracers(:) %keys)!--- "tracers"2110 IF(lerr .AND. ALLOCATED (tracers)) val = fgetKey(tracers(:)) !--- "tracers" 2136 2111 IF(lerr .AND. ASSOCIATED(isotope)) val = fgetKey(isotope%keys(:)) !--- "isotope" 2137 2112 IF(lerr .AND. PRESENT(def)) THEN … … 2145 2120 CHARACTER(LEN=maxlen) FUNCTION fgetKey(ky) RESULT(val) 2146 2121 TYPE(keys_type), INTENT(IN) :: ky(:) 2147 lerr = SIZE(ky) == 02148 IF(lerr) RETURN2149 val = fgetKeyIdx(strIdx(ky%name, tname), [keyn], ky, lerr)2150 IF(lerr) val = fgetKeyIdx(strIdx(ky%name, tnam), [keyn], ky, lerr)2151 2122 CHARACTER(LEN=maxlen), ALLOCATABLE :: tname_all(:) 2123 lerr = SIZE(ky) == 0; IF(lerr) RETURN 2124 lerr = getKey('name', tname_all, ky); IF(lerr) RETURN 2125 val = fgetKeyIdx(strIdx(tname_all, tname), [keyn], ky, lerr) 2126 IF(lerr) val = fgetKeyIdx(strIdx(tname_all, tnam ), [keyn], ky, lerr) 2152 2127 END FUNCTION fgetKey 2153 2128 … … 2166 2141 IF(lerr) RETURN 2167 2142 val = str2int(sval) 2168 lerr = val == -HUGE(1) 2143 lerr = val == -HUGE(1) .AND. sval /= '' 2169 2144 s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(tname)//' is not' 2170 2145 CALL msg(TRIM(s)//' an integer: '//TRIM(sval), modname, lerr) … … 2183 2158 IF(lerr) RETURN 2184 2159 val = str2real(sval) 2185 lerr = val == -HUGE(1.) 2160 lerr = val == -HUGE(1.) .AND. sval /= '' 2186 2161 s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(tname)//' is not' 2187 2162 CALL msg(TRIM(s)//' a real: '//TRIM(sval), modname, lerr) … … 2201 2176 IF(lerr) RETURN 2202 2177 ival = str2bool(sval) 2203 lerr = ival == -1 2178 lerr = ival == -1 .AND. sval /= '' 2204 2179 s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(tname)//' is not' 2205 2180 CALL msg(TRIM(s)//' a boolean: '//TRIM(sval), modname, lerr) … … 2236 2211 IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN 2237 2212 val = str2int(svals) 2238 lerr = ANY(val == -HUGE(1)) 2213 lerr = ANY(val == -HUGE(1)) .AND. sval /= '' 2239 2214 s = 'key "'//TRIM(keyn)//'" of '//TRIM(tname)//' is not' 2240 2215 CALL msg(TRIM(s)//' an integer: '//TRIM(sval), modname, lerr) … … 2256 2231 IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN 2257 2232 val = str2real(svals) 2258 lerr = ANY(val == -HUGE(1.)) 2233 lerr = ANY(val == -HUGE(1.)) .AND. sval /= '' 2259 2234 s = 'key "'//TRIM(keyn)//'" of '//TRIM(tname)//' is not' 2260 2235 CALL msg(TRIM(s)//' a real: '//TRIM(sval), modname, lerr) … … 2277 2252 IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN 2278 2253 ivals = str2bool(svals) 2279 lerr = ANY(ivals == -1) 2254 lerr = ANY(ivals == -1) .AND. sval /= '' 2280 2255 s = 'key "'//TRIM(keyn)//'" of '//TRIM(tname)//' is not' 2281 2256 CALL msg(TRIM(s)//' a boolean: '//TRIM(sval), modname, lerr) … … 2312 2287 IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN 2313 2288 val = str2int(svals) 2314 lerr = ANY(val == -HUGE(1)) 2289 lerr = ANY(val == -HUGE(1)) .AND. sval /= '' 2315 2290 s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(tname)//' is not' 2316 2291 CALL msg(TRIM(s)//' an integer: '//TRIM(sval), modname, lerr) … … 2332 2307 IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN 2333 2308 val = str2real(svals) 2334 lerr = ANY(val == -HUGE(1.)) 2309 lerr = ANY(val == -HUGE(1.)) .AND. sval /= '' 2335 2310 s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(tname)//' is not' 2336 2311 CALL msg(TRIM(s)//' a real: '//TRIM(sval), modname, lerr) … … 2353 2328 IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN 2354 2329 ivals = str2bool(svals) 2355 lerr = ANY(ivals == -1) 2330 lerr = ANY(ivals == -1) .AND. sval /= '' 2356 2331 s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(tname)//' is not' 2357 2332 CALL msg(TRIM(s)//' a boolean: '//TRIM(sval), modname, lerr) … … 2412 2387 lerr = .TRUE. 2413 2388 IF(PRESENT(ky)) THEN; val = fgetKey(ky) !--- "ky" 2414 ELSE IF(ALLOCATED(tracers)) THEN; val = fgetKey(tracers(:) %keys)!--- "tracers"2389 ELSE IF(ALLOCATED(tracers)) THEN; val = fgetKey(tracers(:)) !--- "tracers" 2415 2390 IF(lerr .AND. ASSOCIATED(isotope)) val = fgetKey(isotope%keys(:)) !--- "isotope" 2416 2391 END IF … … 2427 2402 TYPE(keys_type), INTENT(IN) :: ky(:) 2428 2403 LOGICAL, ALLOCATABLE :: ler(:) 2429 lerr = SIZE(ky) == 0; IF(lerr) RETURN 2404 CHARACTER(LEN=maxlen), ALLOCATABLE :: tname_all(:) 2405 lerr = SIZE(ky) == 0; IF(lerr) RETURN 2406 lerr = getKey('name', tname_all, ky); IF(lerr) RETURN 2430 2407 ALLOCATE(ler(SIZE(tname))) 2431 val = [(fgetKeyIdx(strIdx( ky(:)%name, tname(iq)), keyn, ky, ler(iq)), iq = 1, SIZE(tname))]2408 val = [(fgetKeyIdx(strIdx(tname_all, tname(iq)), keyn, ky, ler(iq)), iq = 1, SIZE(tname))] 2432 2409 lerr = ANY(ler) 2433 2410 END FUNCTION fgetKey … … 2449 2426 IF(lerr) RETURN 2450 2427 val = str2int(svals) 2451 ll = val == -HUGE(1) 2428 ll = val == -HUGE(1) .AND. (SIZE(svals) /=1 .OR. svals(1) /= '') 2452 2429 lerr = ANY(ll); IF(.NOT.lerr) RETURN 2453 2430 s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(strStack(tname, MASK=ll))//' is not' … … 2469 2446 IF(lerr) RETURN 2470 2447 val = str2real(svals) 2471 ll = val == -HUGE(1.) 2448 ll = val == -HUGE(1.) .AND. (SIZE(svals) /=1 .OR. svals(1) /= '') 2472 2449 lerr = ANY(ll); IF(.NOT.lerr) RETURN 2473 2450 s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(strStack(tname, MASK=ll))//' is not' … … 2490 2467 IF(lerr) RETURN 2491 2468 ivals = str2bool(svals) 2492 ll = ivals == -1 2469 ll = ivals == -1 .AND. (SIZE(svals) /=1 .OR. svals(1) /= '') 2493 2470 lerr = ANY(ll); IF(.NOT.lerr) THEN; val = ivals == 1; RETURN; END IF 2494 2471 s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(strStack(tname, MASK=ll))//' is not' … … 2502 2479 !============================================================================================================================== 2503 2480 SUBROUTINE setKeysDBase(tracers_, isotopes_, isotope_) 2504 TYPE( trac_type), OPTIONAL, INTENT(IN) :: tracers_(:)2481 TYPE(keys_type), OPTIONAL, INTENT(IN) :: tracers_(:) 2505 2482 TYPE(isot_type), OPTIONAL, INTENT(IN) :: isotopes_(:) 2506 2483 TYPE(isot_type), OPTIONAL, INTENT(IN) :: isotope_ … … 2511 2488 IF(PRESENT(isotopes_)) THEN; isotopes = isotopes_; ELSE; ALLOCATE(isotopes(0)); END IF 2512 2489 IF(PRESENT(isotope_ )) THEN 2513 ix = strIdx(isotopes(:)% parent, isotope_%parent)2490 ix = strIdx(isotopes(:)%name, isotope_%name) 2514 2491 IF(ix /= 0) THEN 2515 2492 isotopes(ix) = isotope_ … … 2522 2499 !============================================================================================================================== 2523 2500 SUBROUTINE getKeysDBase(tracers_, isotopes_, isotope_) 2524 TYPE( trac_type), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: tracers_(:)2501 TYPE(keys_type), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: tracers_(:) 2525 2502 TYPE(isot_type), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: isotopes_(:) 2526 2503 TYPE(isot_type), OPTIONAL, INTENT(OUT) :: isotope_ … … 2529 2506 IF(PRESENT( tracers_)) THEN; tracers_ = tracers; ELSE; ALLOCATE( tracers_(0)); END IF 2530 2507 IF(PRESENT(isotopes_)) THEN; isotopes_ = isotopes; ELSE; ALLOCATE(isotopes_(0)); END IF 2531 IF(PRESENT(isotope_ )) THEN; ix = strIdx(isotopes(:)% parent, isotope%parent); IF(ix /= 0) isotope_=isotopes(ix); END IF2508 IF(PRESENT(isotope_ )) THEN; ix = strIdx(isotopes(:)%name, isotope%name); IF(ix /= 0) isotope_=isotopes(ix); END IF 2532 2509 END SUBROUTINE getKeysDBase 2533 2510 !============================================================================================================================== … … 2605 2582 CHARACTER(LEN=*), INTENT(IN) :: tname 2606 2583 TYPE(keys_type), INTENT(IN) :: keys 2607 TYPE( trac_type), ALLOCATABLE, INTENT(INOUT) :: tracs(:)2608 TYPE( trac_type), ALLOCATABLE :: tr(:)2584 TYPE(keys_type), ALLOCATABLE, INTENT(INOUT) :: tracs(:) 2585 TYPE(keys_type), ALLOCATABLE :: tr(:) 2609 2586 CHARACTER(LEN=maxlen), ALLOCATABLE :: tnames(:) 2610 2587 INTEGER :: nt, ix 2611 2588 IF(ALLOCATED(tracs)) THEN 2612 lerr = getKey('name', tnames, ky=tracs(:) %keys); IF(lerr) RETURN2589 lerr = getKey('name', tnames, ky=tracs(:)); IF(lerr) RETURN 2613 2590 nt = SIZE(tracs) 2614 2591 ix = strIdx(tnames, tname) … … 2622 2599 ix = 1; ALLOCATE(tracs(1)) 2623 2600 END IF 2624 CALL addKey('name', tname, tracs(ix)%keys) 2625 tracs(ix)%name = tname 2626 tracs(ix)%keys = keys 2601 CALL addKey('name', tname, tracs(ix)) 2602 tracs(ix) = keys 2627 2603 2628 2604 END FUNCTION addTracer_1 … … 2639 2615 LOGICAL FUNCTION delTracer_1(tname, tracs) RESULT(lerr) 2640 2616 CHARACTER(LEN=*), INTENT(IN) :: tname 2641 TYPE( trac_type), ALLOCATABLE, TARGET, INTENT(INOUT) :: tracs(:)2642 TYPE( trac_type), ALLOCATABLE :: tr(:)2617 TYPE(keys_type), ALLOCATABLE, TARGET, INTENT(INOUT) :: tracs(:) 2618 TYPE(keys_type), ALLOCATABLE :: tr(:) 2643 2619 CHARACTER(LEN=maxlen), ALLOCATABLE :: tnames(:) 2644 2620 INTEGER :: nt, ix … … 2646 2622 IF(fmsg('Can''t remove tracer "'//TRIM(tname)//'" from an empty tracers descriptor', modname, lerr)) RETURN 2647 2623 nt = SIZE(tracs) 2648 lerr = getKey('name', tnames, ky=tracs(:) %keys); IF(lerr) RETURN2624 lerr = getKey('name', tnames, ky=tracs(:)); IF(lerr) RETURN 2649 2625 ix = strIdx(tnames, tname) 2650 2626 CALL msg('Removing tracer "' //TRIM(tname)//'"', modname, ix /= 0) … … 2690 2666 2691 2667 !============================================================================================================================== 2692 !============ CONVERT WATER-DERIVED NAMES FROM FORMER TO CURRENT CONVENTION ; OTHER NAMES ARE LEFT UNTOUCHED ================== 2693 !======= NAMES STRUCTURE: H2O[<phase>][_<isotope>][_<tag>] (<phase> from "old_phases", <isotope> from "oldH2OIso") ============ 2668 !======== CONVERT WATER-DERIVED NAMES FROM FORMER TO CURRENT CONVENTION & VICE VERSA ; OTHER NAMES ARE LEFT UNTOUCHED ========= 2669 !===== OLD NAMES STRUCTURE: H2O[<phase>][_<isotope>][_<tag>] (<phase> from "old_phases", <isotope> from "oldH2OIso") == 2670 !==== NEW NAMES STRUCTURE: <var>[<phase_sep><phase>][_<tag>] (<phase> from "known_phases", <var>='H2O' or from "newH2OIso") == 2694 2671 !============================================================================================================================== 2695 2672 CHARACTER(LEN=maxlen) FUNCTION old2newH2O_1(oldName, iPhase) RESULT(newName) … … 2724 2701 END FUNCTION old2newH2O_m 2725 2702 !============================================================================================================================== 2726 2727 2728 !==============================================================================================================================2729 !============ CONVERT WATER-DERIVED NAMES FROM CURRENT TO FORMER CONVENTION ; OTHER NAMES ARE LEFT UNTOUCHED ==================2730 !==== NAMES STRUCTURE: <var>[<phase_sep><phase>][_<tag>] (<phase> from "known_phases", <var> = 'H2O' or from "newH2OIso") =====2731 !==============================================================================================================================2732 2703 CHARACTER(LEN=maxlen) FUNCTION new2oldH2O_1(newName, iPhase) RESULT(oldName) 2733 2704 CHARACTER(LEN=*), INTENT(IN) :: newName
Note: See TracChangeset
for help on using the changeset viewer.