133dc97f67
Former-commit-id:06a8b51d6d[formerly9f19e3f712[formerly 64fa9254b946eae7e61bbc3f513b7c3696c4f54f]] Former-commit-id:9f19e3f712Former-commit-id:a02aeb236c
129 lines
4.2 KiB
Fortran
129 lines
4.2 KiB
Fortran
C MODULE CHEKRC
|
|
C-----------------------------------------------------------------------
|
|
C
|
|
C CHECKS FOR EXISTENCE OF RATING CURVE FOR BOTH OPER AND MCP PROG.
|
|
C
|
|
SUBROUTINE CHEKRC (RCIDI,IER)
|
|
C
|
|
C ROUTINE CHEKRC DETERMINES THE EXISTENCE OF A RATING CURVE FOR
|
|
C BOTH THE OPERATIONAL AND CALIBRATION PROGRAM. FOR THE OPERATIONAL
|
|
C PROGRAM, /FRATNG/ IS FIRST CHECKED TO SEE IF THE REQUESTED RATING
|
|
C CURVE IS ALREADY IN MEMORY. IF IT'S NOT THERE, THE FILE IS SEARCHED
|
|
C BY CALLING FGETRC. THE NO. OF POINTS DEFINING THE CURVE IS THEN
|
|
C CHECKED AS THEY MUST NUMBER GREATER THAN 1.
|
|
C
|
|
C FOR THE CALIBRATION PROGRAM, /FRATNG/ IS CHECKED TO SEE IF THE
|
|
C RATING CURVE IS IN MEMORY. IF NOT THERE, /FRCFIL/ IS SCANNED TO
|
|
C FIND A MATCH ON THE IDENTIFIER. IF FOUND, THE LAST USE DATE OF
|
|
C THE RATING CURVE IS COMPARED AGAINST THE ENDING RUN DATE FOR THIS
|
|
C PARTICULAR MCP RUN. IF THE LAST USE DATE IS BEFORE THE ENDING DATE,
|
|
C IT IS AN ERROR (I.E. - IER IS SET TO 1).
|
|
C
|
|
C IN BOTH ENVIRONMENTS, IF THE RATING CURVE IS NOT FOUND, IT IS AN
|
|
C ERROR.
|
|
C
|
|
C ARGUMENT LIST:
|
|
C RCIDI - 8 CHARACTER RATING CURVE IDENTIFIER TO BE SEARCHED FOR
|
|
C IER - ERROR FLAG; =0, NO ERROR, =1, ERROR OCCURRED.
|
|
C
|
|
C ROUTINE ORIGINALLY WRITTEN BY - JOE OSTROWSKI - HRL - 8/1980
|
|
C
|
|
CHARACTER*8 OLDOPN
|
|
C
|
|
DIMENSION RCIDI(2),IBUFRC(300),ZBUFRC(300)
|
|
EQUIVALENCE (IBUFRC(1),ZBUFRC(1))
|
|
C
|
|
INCLUDE 'common/ionum'
|
|
INCLUDE 'common/fdbug'
|
|
INCLUDE 'common/fprog'
|
|
INCLUDE 'common/fratng'
|
|
INCLUDE 'common/frcfil'
|
|
INCLUDE 'common/fcunit'
|
|
INCLUDE 'common/fctime'
|
|
INCLUDE 'common/errdat'
|
|
C
|
|
C ================================= RCS keyword statements ==========
|
|
CHARACTER*68 RCSKW1,RCSKW2
|
|
DATA RCSKW1,RCSKW2 / '
|
|
.$Source: /fs/hseb/ob72/rfc/ofs/src/fcinit_util/RCS/chekrc.f,v $
|
|
. $', '
|
|
.$Id: chekrc.f,v 1.4 2001/06/19 18:15:42 dws Exp $
|
|
. $' /
|
|
C ===================================================================
|
|
C
|
|
C
|
|
IOPNUM=-1
|
|
CALL FSTWHR ('CHEKRC ',IOPNUM,OLDOPN,IOLDOP)
|
|
C
|
|
IER=0
|
|
C
|
|
IBUG=IFBUG('RTCV')
|
|
C
|
|
IF (ITRACE.GE.1) WRITE (IODBUG,*) 'ENTER CHEKRC'
|
|
C
|
|
IF (IBUG.GE.1) WRITE (IODBUG,'(1X,A,1X,2A4)') ' RCIDI=',RCIDI,
|
|
* ' RTCVID=',RTCVID
|
|
C
|
|
C CHECK IF RATING CURVE IS IN COMMON FRATNG
|
|
IF (RCIDI(1).EQ.RTCVID(1).AND.RCIDI(2).EQ.RTCVID(2)) GO TO 20
|
|
C
|
|
C CHECK IF PROGRAM IS MCP
|
|
IF (MAINUM.GE.3) GO TO 40
|
|
C
|
|
CALL FGETRC (RCIDI,IER2)
|
|
IF (IER2.EQ.0) GO TO 20
|
|
WRITE(IPR,10) RCIDI
|
|
10 FORMAT ('0**ERROR** RATING CURVE ',2A4,' NOT DEFINED.')
|
|
CALL ERROR
|
|
IER=1
|
|
GO TO 80
|
|
C
|
|
C AN OPERATION CAN NOT USE A RATING CURVE DEFINED WITH LESS THAN
|
|
C TWO POINTS
|
|
20 IF (NRCPTS.GE.2) GO TO 80
|
|
WRITE (IPR,30) RCIDI
|
|
30 FORMAT ('0**ERROR** RATING CURVE ',2A4,' HAS BEEN FOUND ',
|
|
* 'BUT IT HAS NO POINTS DEFINING IT. IT CANNOT BE USED ',
|
|
* 'WITH ANY OPERATION.')
|
|
CALL ERROR
|
|
IER=1
|
|
GO TO 80
|
|
C
|
|
C THIS SECTION FOR PROGRAM MCP.
|
|
C CHECK COMMON FRCFIL FOR RATING CURVE AND IF FOUND CHECK LAST USE
|
|
C DATE AGAINST ENDING RUN DATE.
|
|
40 DO 50 I=1,NDEF
|
|
IF (RCIDI(1).EQ.RCNAME(1,I).AND.RCIDI(2).EQ.RCNAME(2,I)) THEN
|
|
LAST = LOCL(I)
|
|
GO TO 60
|
|
ENDIF
|
|
50 CONTINUE
|
|
C
|
|
C RATING CURVE NOT FOUND
|
|
WRITE (IPR,10) RCIDI
|
|
CALL ERROR
|
|
IER=1
|
|
GO TO 80
|
|
C
|
|
C READ THE LAST DEFINITION FOR THIS RATING CURVE TO FIND LAST USE DATE
|
|
60 READ (IRC,REC=LAST) IBUFRC
|
|
LASRC = IBUFRC(41)
|
|
IF (IBUG.GE.1) WRITE (IODBUG,*) 'LASRC=',LASRC,' LDARUN=',LDARUN
|
|
IF (LASRC.GE.LDARUN.OR.LASRC.EQ.0) GO TO 80
|
|
CALL MDYH1 (LASRC,1,IM,ID,IY,IH,NOUTZ,NOUTDS,CODE)
|
|
CALL MDYH1 (LDARUN,1,JM,JD,JY,JH,NOUTZ,NOUTDS,CODE)
|
|
WRITE (IPR,70) RCIDI,IM,ID,IY,JM,JD,JY
|
|
70 FORMAT ('0**ERROR** THE LAST USE DATE FOR RATING CURVE ',2A4,' (',
|
|
* I2.2,'/',I2.2,'/',I2.2,
|
|
* ' IS BEFORE THE ENDING RUN DATE (',
|
|
* I2.2,'/',I2.2,'/',I2.2,').')
|
|
IER=1
|
|
CALL ERROR
|
|
GO TO 80
|
|
C
|
|
80 IF (ITRACE.GE.1) WRITE (IODBUG,*) 'EXIT CHEKRC'
|
|
C
|
|
CALL FSTWHR (OLDOPN,IOLDOP,OLDOPN,IOLDOP)
|
|
C
|
|
RETURN
|
|
END
|