*----------------------------------------------------------------------- * GLRQNP / GLRQID / GLRQCP / GLRQVL / GLRSVL *----------------------------------------------------------------------- SUBROUTINE GLRQNP(NCP) CHARACTER CP*(*) PARAMETER (NPARA = 6) REAL RX(NPARA) LOGICAL LW(NPARA), LCHREQ, LFIRST CHARACTER CPARAS(NPARA)*8 CHARACTER CPARAL(NPARA)*40 CHARACTER CMSG*80 EXTERNAL LCHREQ, LENC SAVE * ---- SHORT NAME ---- DATA CPARAS(1) / 'RMISS ' /, RX(1) / 999.0 / DATA CPARAS(2) / 'RUNDEF ' /, RX(2) / -999.0 / DATA CPARAS(3) / 'REPSL ' /, RX(3) / 1.19221E-06 / DATA CPARAS(4) / 'RFACT ' /, RX(4) / 1.0 / DATA CPARAS(5) / 'REALMAX ' /, RX(5) / Z'7F7FFFFF' / DATA CPARAS(6) / 'REALMIN ' /, RX(6) / Z'00800000' / * ---- LONG NAME ---- DATA CPARAL(1) / 'RMISS ' /, LW(1) / .TRUE. / DATA CPARAL(2) / 'RUNDEF ' /, LW(2) / .TRUE. / DATA CPARAL(3) / 'REPSL ' /, LW(3) / .FALSE. / DATA CPARAL(4) / 'RFACT ' /, LW(4) / .TRUE. / DATA CPARAL(5) / 'REALMAX ' /, LW(5) / .FALSE. / DATA CPARAL(6) / 'REALMIN ' /, LW(6) / .FALSE. / DATA LFIRST / .TRUE. / NCP = NPARA RETURN *----------------------------------------------------------------------- ENTRY GLRQID(CP, IDX) DO 10 N = 1, NPARA IF (LCHREQ(CP,CPARAS(N)) .OR. & LCHREQ(CP,CPARAL(N))) THEN IDX = N RETURN END IF 10 CONTINUE CMSG='PARAMETER '''//CP(1:LENC(CP))//''' IS NOT DEFINED.' CALL MSGDMP('E', 'GLRQID', CMSG) RETURN *----------------------------------------------------------------------- ENTRY GLRQCP(IDX, CP) IF (1.LE.IDX .AND. IDX.LE.NPARA) THEN CP = CPARAS(IDX) ELSE CALL MSGDMP('E', 'GLRQCP', 'IDX IS OUT OF RANGE.') END IF RETURN *----------------------------------------------------------------------- ENTRY GLRQCL(IDX, CP) IF (1.LE.IDX .AND. IDX.LE.NPARA) THEN CP = CPARAL(IDX) ELSE CALL MSGDMP('E', 'GLRQCL', 'IDX IS OUT OF RANGE.') END IF RETURN *----------------------------------------------------------------------- ENTRY GLRQVL(IDX, RPARA) IF (LFIRST) THEN CALL RTRGET('GL:', CPARAS, RX, NPARA) CALL RLRGET(CPARAL, RX, NPARA) LFIRST = .FALSE. ENDIF IF (1.LE.IDX .AND. IDX.LE.NPARA) THEN RPARA = RX(IDX) ELSE CALL MSGDMP('E','GLRQVL','IDX IS OUT OF RANGE.') END IF RETURN *----------------------------------------------------------------------- ENTRY GLRSVL(IDX, RPARA) IF (LFIRST) THEN CALL RTRGET('GL:', CPARAS, RX, NPARA) CALL RLRGET(CPARAS, RX, NPARA) LFIRST = .FALSE. END IF IF (1.LE.IDX .AND. IDX.LE.NPARA) THEN IF (LW(IDX)) THEN RX(IDX) = RPARA RETURN ELSE CMSG = 'PARAMETER'''//CPARAS(IDX)//''' CANNOT BE SET.' CALL MSGDMP('E', 'GLRQVL', CMSG) ENDIF ELSE CALL MSGDMP('E','GLRQVL','IDX IS OUT OF RANGE.') END IF RETURN *----------------------------------------------------------------------- ENTRY GLRQIN(CP, IN) DO 20 N = 1, NPARA IF (LCHREQ(CP, CPARAS(N)) .OR. & LCHREQ(CP, CPARAL(N))) THEN IN = N RETURN ENDIF 20 CONTINUE IN = 0 RETURN END