MODULE GASQAL_SUB CONTAINS SUBROUTINE GASQAL ( QALSTR, FAIL, ERRMSG ) ! ! VERSION ! 24APR26 AD Bug#54: Ensure NISO defined if vib.levs come first ! 08FEB26 AD Checked. ! 03OCT17 AD F90 conversion. Checked. ! ! DESCRIPTION ! Set isotope/band qualifiers for each molecule ! Called by GASCHK for each molecule with appended qualifier string. ! The layout of qualifiers is, eg for CO2, ! CO2(3:4)(1:2)(2)(1)(2:3)(3)(1:3)(2:4)(4)(5) ! which will (a) select bands (3:4), (1:2) for all isotopes ! (b) select band (2:3) for isotopes 1,2 ! (c) select bands (1:3), (2:3) for isotope 3 ! (d) select all bands for isotopes 4,5 ! Implicitly this is CO2(*)(user-qualifiers)(*:*), ie starts with all ! isotopes selected, ends with all bands selected. Decoded as pairs of ! (isotopes)x(applicable bands) ! ! VARIABLE KINDS USE KIND_DAT ! ! GLOBAL DATA USE GASCOM_DAT ! Molecule and isotope data ! ! SUBROUTINES USE ADDQAL_SUB ! Add to list of molec iso/band qualifiers USE C11INT_FNC ! Write integer as left-adjusted string USE REAQAL_SUB ! Decode Qualifier strings '(IQAL)' or '(IQAL:JQAL)' USE USEQAL_FNC ! Set TRUE if listed in line molecule qualifiers USE WRTLOG_SUB ! Write text message to log file ! IMPLICIT NONE ! ! ARGUMENTS CHARACTER(*), INTENT(INOUT) :: QALSTR ! String containing qualifiers LOGICAL, INTENT(OUT) :: FAIL ! Set TRUE if fatal error is detected CHARACTER(80), INTENT(OUT) :: ERRMSG ! Error message written if FAIL ! ! LOCAL VARIABLES LOGICAL :: LASBND ! T=last qualifier read was a band (F=an isotope) LOGICAL :: TWOQAL ! T=pair of qualifiers, F=single qualifier INTEGER(I4) :: IDXMOL ! HITRAN/RFM index of molecule INTEGER(I4) :: IISO ! Isotope counter INTEGER(I4) :: ILS ! Selected lower state Global Quantum number INTEGER(I4) :: IQAL ! Qualifier counter INTEGER(I4) :: ISO ! Isotope counter/index INTEGER(I4) :: IUS ! Selected upper state Global Quantum number INTEGER(I4) :: JISO ! Secondary isotope counter INTEGER(I4) :: NISMAX ! Max no.isotopes for this molecule INTEGER(I4) :: NISO ! No.of isotopes in ISOLST INTEGER(I4) :: ISOLST(MAXISO) ! List of isotopes using current band CHARACTER(30) :: ERRSTR ! Substring for error messages CHARACTER(80) :: LOGMSG ! Message sent to RFM log file ! ! EXECUTABLE CODE -------------------------------------------------------------- ! IF ( LEN_TRIM ( QALSTR ) .EQ. 0 ) RETURN ! LOGMSG = 'I-GASQAL: Gas=' // GAS(NGAS)%COD // & ' List of selected isotopes and/or bands ... ' CALL WRTLOG ( LOGMSG ) ! ! Initialise for each new gas GAS(NGAS)%QAL = .TRUE. IQAL = 0 LASBND = .TRUE. IDXMOL = GAS(NGAS)%IDM NISMAX = GAS(NGAS)%NIS NISO = NISMAX ! Initially assume all isotopes selected ! IF ( NISMAX .EQ. 0 ) THEN FAIL = .TRUE. ERRMSG = 'F-GASQAL: No isotopes defined for ' // GAS(NGAS)%COD RETURN END IF ! ! Repeat until all qualifiers decoded from QALSTR DO WHILE ( QALSTR(1:1) .EQ. '(' ) IQAL = IQAL + 1 ! ! Set up substring for any error messages applicable to this gas/qualifier WRITE ( ERRSTR, '(A,I2,A)' ) & 'F-GASQAL: Gas='//GAS(NGAS)%COD//' Qual#', IQAL, ':' ! ! Read qualifier contents CALL REAQAL ( QALSTR, ISO, FAIL, ERRMSG, TWOQAL, IUS ) IF ( FAIL ) RETURN ! Single qualifier, interpreted as isotope# IF ( .NOT. TWOQAL ) THEN ! ! Check valid isotope# IF ( ISO .EQ. 0 .OR. ABS ( ISO ) .GT. NISMAX ) THEN FAIL = .TRUE. ERRMSG = ERRSTR // 'bad isotope#=' // TRIM(C11INT(ISO)) // & ' (range=1:' // TRIM(C11INT(NISMAX)) // ')' RETURN END IF ! ! If starting new isotope list then initialise ISOLST depending on whether ! isotopes are specified as being added or removed IF ( LASBND ) THEN LASBND = .FALSE. ! modifying isotope list IF ( ISO .GT. 0 ) THEN ! specifying isotope to be added NISO = 0 ! start new list of isotopes ELSE ! specifying isotope to be removed ISOLST = (/ ( IISO, IISO = 1, NISMAX ) /) ! 1,2... etc NISO = NISMAX END IF END IF ! IF ( ISO .GT. 0 ) THEN ! add isotope to list CALL WRTLOG ( 'I-GASQAL: Select isotope#' // C11INT(ISO) ) IF ( ANY ( ISOLST(1:NISO) .EQ. ISO ) ) THEN ! check iso is new in list FAIL = .TRUE. ERRMSG = ERRSTR // 'repeated isotope#' // C11INT(ISO) RETURN END IF NISO = NISO + 1 ISOLST(NISO) = ISO ! ELSE ! remove isotope from list CALL WRTLOG ( 'I-GASQAL: Deselect isotope#' // C11INT(ISO) ) JISO = 0 DO IISO = 1, NISO ! Copy all remaining isotopes back to ISOLST IF ( ISOLST(IISO) .NE. ABS(ISO) ) THEN JISO = JISO + 1 ISOLST(JISO) = ISOLST(IISO) END IF END DO IF ( JISO .NE. NISO-1 ) THEN FAIL = .TRUE. WRITE ( ERRMSG, '(A,I2,A)' ) & ERRSTR // 'isotope#', ABS(ISO), ' not previously selected' RETURN END IF NISO = NISO - 1 END IF ! Two qualifiers, interpreted as low:high vib.level numbers ELSE ILS = ISO IF ( ILS .LT. 0 .OR. ILS .GT. 999 ) THEN FAIL = .TRUE. ERRMSG = ERRSTR // 'ILSGQ out of range 0:999, value=' // C11INT(ILS) RETURN END IF IF ( IUS .LT. 0 .OR. IUS .GT. 999 ) THEN FAIL = .TRUE. ERRMSG = ERRSTR // 'IUSGQ out of range 0:999, value=' // C11INT(IUS) RETURN END IF LASBND = .TRUE. ! If using all isotopes just use 'ISO=0' as wildcard IF ( NISO .EQ. NISMAX ) THEN ISOLST(1) = 0 NISO = 1 END IF ! Check that qualifier not already listed DO IISO = 1, NISO IF ( USEQAL ( IDXMOL, ISOLST(IISO), ILS, IUS ) ) THEN FAIL = .TRUE. ERRMSG = ERRSTR // 'isotope#' // TRIM(C11INT(ISO)) // & 'repeated band (ILS:IUS)' RETURN END IF END DO CALL ADDQAL ( IDXMOL, ISOLST(1:NISO), ILS, IUS ) ! LOGMSG = 'I-GASQAL: Select lines from vib.band low:high=' // & TRIM ( C11INT(ILS) ) // ':' // TRIM ( C11INT(IUS) ) CALL WRTLOG ( LOGMSG ) END IF ! END DO ! ! Successfully decoded entire QALSTR ! ! Check if finished with an isotope list, in which case set ILS,IUS wildcards IF ( .NOT. LASBND ) THEN IF ( NISO .EQ. NISMAX ) THEN ISOLST(1) = 0 NISO = 1 CALL WRTLOG ( 'W-GASQAL: all isotopes selected' ) END IF CALL WRTLOG ( 'I-GASQAL: Select all bands' ) DO IISO = 1, NISO IF ( USEQAL ( IDXMOL, ISOLST(IISO), 0, 0 ) ) THEN FAIL = .TRUE. ERRMSG = ERRSTR // 'bands already selected for isotope#' // & C11INT( ISOLST(ISO) ) RETURN END IF END DO CALL ADDQAL ( IDXMOL, ISOLST(1:NISO), 0, 0 ) END IF ! ! Normal exit FAIL = .FALSE. ! END SUBROUTINE GASQAL END MODULE GASQAL_SUB