SUBROUTINE UPDT_LSM() C---------------------------------------------------------------------- C- C- Purpose and Methods : Update a section of the current LSM file. C- C- Inputs : C- Outputs : C- Controls: C- C- Created 20-AUG-1990 MICHIGAN STATE UNIVERSITY, TRIGGER CONTROL SOFTWARE C- C---------------------------------------------------------------------- IMPLICIT NONE C---------------------------------------------------------------------- C C Global Declarations C INCLUDE 'LSMP$SOURCE:PARSE_TOKENS.PARAMS' INCLUDE 'LSMP$SOURCE:PARSE_TOKENS.INC' INCLUDE 'D0$PARAMS:LEVEL1_LOOKUP.PARAMS' INCLUDE 'D0$INC:LEVEL1_LOOKUP.INC' INCLUDE 'LSMP$SOURCE:LEVEL1_LOOKUP_EXPANSION.INC' INTEGER PFNUM EXTERNAL PFNUM INTEGER TRULEN EXTERNAL TRULEN C C Local variables C LOGICAL OK REAL SAVE_SLOPES(POS_ETA:NEG_ETA, & ETA_RANGE_MIN:ETA_RANGE_MAX, & PHI_MIN:PHI_MAX, & EM_PROM:PY_PROM, & PAGE_INDEX_MIN:PAGE_INDEX_MAX) INTEGER SIGN_ETA, MAGN_ETA, PHI, PROM, INDEX INTEGER LUQ_BYTE(EM_ET_QUANT:PY_QUANT) INTEGER LUQ CHARACTER*40 REV_DIRECTORY_NAME CHARACTER*40 REV_FILE_NAME CHARACTER*5 REVISION_STRING_1 CHARACTER*5 REVISION_STRING_2 INTEGER REVISION_NUMBER_2 CHARACTER*90 FULL_NAME_IN CHARACTER*90 FULL_NAME_OUT LOGICAL UPDT_PRC LOGICAL UPDT_PTC LOGICAL UPDT_GEOM INTEGER UNIT_IN INTEGER UNIT_OUT INTEGER ROUTINE_ID PARAMETER (ROUTINE_ID = 362) CHARACTER*120 BUFFER INTEGER ERROR CHARACTER*1 LAST_CHAR INTEGER LENGTH INTEGER NAME_LENGTH_IN, NAME_LENGTH_OUT C INTEGER NUM_PARAMETERS PARAMETER (NUM_PARAMETERS = 9) CHARACTER*33 PROMPTS( NUM_PARAMETERS ) CHARACTER*1 TYPES( NUM_PARAMETERS ) INTEGER LIMITS(2, NUM_PARAMETERS) C C Check if a file has been loaded C IF (LSM_FILE_LOADED .NEQV. .TRUE.) THEN CALL OUTMSG('1Cannot proceed without an LSM file loaded') CALL PFWAIT() GOTO 999 ENDIF C C Initialize parameters before call to GETPAR C PROMPTS(1) = 'Directory of input file' TYPES(1) = 'C' LIMITS(1,1) = 0 LIMITS(2,1) = 0 C PROMPTS(2) = 'Name of input file' TYPES(2) = 'C' LIMITS(1,2) = 0 LIMITS(2,2) = 0 C PROMPTS(3) = 'Revision number of input file' TYPES(3) = 'I' LIMITS(1,3) = -1 LIMITS(2,3) = 9999 C PROMPTS(4) = 'Directory of ouput file' TYPES(4) = 'C' LIMITS(1,4) = 0 LIMITS(2,4) = 0 REV_DIRECTORY_NAME = LSM_DIRECTORY_NAME C PROMPTS(5) = 'Name of output file' TYPES(5) = 'C' LIMITS(1,5) = 0 LIMITS(2,5) = 0 REV_FILE_NAME = LSM_FILE_NAME C PROMPTS(6) = 'Revision number of output file' TYPES(6) = 'I' LIMITS(1,6) = 0 LIMITS(2,6) = 9999 REVISION_NUMBER_2 = LSM_REVISION_NUMBER + 1 C PROMPTS(7) = 'Update section PROM_OUTPUT_CUTS' TYPES(7) = 'L' LIMITS(1,7) = 0 LIMITS(2,7) = 0 UPDT_PRC = .TRUE. C PROMPTS(8) = 'Update sect PROM_TRANSFER_COEFF' TYPES(8) = 'L' LIMITS(1,8) = 0 LIMITS(2,8) = 0 UPDT_PTC = .TRUE. C PROMPTS(9) = 'Update Tower Geometry' TYPES(9) = 'L' LIMITS(1,9) = 0 LIMITS(2,9) = 0 UPDT_GEOM = .FALSE. C CALL GETDIS(NUM_PARAMETERS, PROMPTS, TYPES, LIMITS, & LSM_DIRECTORY_NAME, LSM_FILE_NAME, LSM_REVISION_NUMBER, & REV_DIRECTORY_NAME, REV_FILE_NAME, REVISION_NUMBER_2, UPDT_PRC, & UPDT_PTC, UPDT_GEOM) C C Check if ABORT was selected in the above call IF (PFNUM() .NE. 0) GOTO 999 C C Compile the selected quantities C IF ((UPDT_PTC .EQV. .TRUE.) .AND. (UPDT_PRC .EQV. .TRUE.)) THEN CALL COMPILE_ALL_PROM_SLOPES() CALL COMPILE_ALL_PROM_CUTS() ELSEIF (UPDT_PTC .EQV. .TRUE.) THEN CALL COMPILE_ALL_PROM_SLOPES() ELSEIF (UPDT_PRC .EQV. .TRUE.) THEN C C If the cuts are to be updated, the slopes must be also. If the slopes C are not to be updated, save them and restore them when through C DO INDEX = PAGE_INDEX_MIN, PAGE_INDEX_MAX DO PROM = EM_PROM, PY_PROM DO PHI = PHI_MIN, PHI_MAX DO MAGN_ETA = ETA_RANGE_MIN, ETA_RANGE_MAX DO SIGN_ETA = POS_ETA, NEG_ETA SAVE_SLOPES(SIGN_ETA, MAGN_ETA, PHI, PROM, INDEX) = & PROM_SLOPE(SIGN_ETA, MAGN_ETA, PHI, PROM, INDEX) END DO END DO END DO END DO END DO C CALL COMPILE_ALL_PROM_SLOPES() CALL COMPILE_ALL_PROM_CUTS() DO INDEX = PAGE_INDEX_MIN, PAGE_INDEX_MAX DO PROM = EM_PROM, PY_PROM DO PHI = PHI_MIN, PHI_MAX DO MAGN_ETA = ETA_RANGE_MIN, ETA_RANGE_MAX DO SIGN_ETA = POS_ETA, NEG_ETA PROM_SLOPE(SIGN_ETA, MAGN_ETA, PHI, PROM, INDEX) = & SAVE_SLOPES(SIGN_ETA, MAGN_ETA, PHI, PROM, INDEX) END DO END DO END DO END DO END DO ENDIF C C Build the input and output file names C FULL_NAME_IN = ' ' FULL_NAME_OUT = ' ' C LENGTH = TRULEN(LSM_DIRECTORY_NAME) LAST_CHAR = LSM_DIRECTORY_NAME(LENGTH:LENGTH) IF ((LAST_CHAR .NE. ':') .AND. (LAST_CHAR .NE. ']') .AND. & (LENGTH .LT. 40) .AND. (LENGTH .GE. 1)) THEN LSM_DIRECTORY_NAME(LENGTH+1:LENGTH+1) = ':' ENDIF C LENGTH = TRULEN(REV_DIRECTORY_NAME) LAST_CHAR = REV_DIRECTORY_NAME(LENGTH:LENGTH) IF ((LAST_CHAR .NE. ':') .AND. (LAST_CHAR .NE. ']') .AND. & (LENGTH .LT. 40) .AND. (LENGTH .GE. 1)) THEN REV_DIRECTORY_NAME(LENGTH+1:LENGTH+1) = ':' ENDIF C FULL_NAME_IN = LSM_DIRECTORY_NAME(1:TRULEN(LSM_DIRECTORY_NAME)) // & LSM_FILE_NAME(1:TRULEN(LSM_FILE_NAME)) IF ( LSM_REVISION_NUMBER .GE. 0 ) THEN WRITE( REVISION_STRING_1, 100) LSM_REVISION_NUMBER 100 FORMAT( '_', I4.4 ) FULL_NAME_IN = FULL_NAME_IN(1:TRULEN(FULL_NAME_IN)) & // REVISION_STRING_1 ENDIF FULL_NAME_IN = FULL_NAME_IN(1:TRULEN(FULL_NAME_IN)) // '.LSM' C WRITE( REVISION_STRING_2, 100) REVISION_NUMBER_2 C FULL_NAME_OUT = REV_DIRECTORY_NAME(1:TRULEN(REV_DIRECTORY_NAME)) & // REV_FILE_NAME(1:TRULEN(REV_FILE_NAME)) // REVISION_STRING_2 & // '.LSM' C NAME_LENGTH_IN = TRULEN(FULL_NAME_IN) NAME_LENGTH_OUT = TRULEN(FULL_NAME_OUT) CALL OUTMSG(' Reading from file: '// & FULL_NAME_IN(1:NAME_LENGTH_IN)) CALL OUTMSG(' Writing to file: '// & FULL_NAME_OUT(1:NAME_LENGTH_OUT)) C C Get some unit numbers so we can do some IO C CALL GTUNIT(ROUTINE_ID, UNIT_IN, ERROR) IF (ERROR .NE. 0) CALL ABORT('Error calling GTUNIT in UPDT_LSM') CALL GTUNIT(ROUTINE_ID, UNIT_OUT, ERROR) IF (ERROR .NE. 0) CALL ABORT('Error calling GTUNIT in UPDT_LSM') C C Open the files C CALL D0OPEN(UNIT_IN, FULL_NAME_IN, 'IF', OK) IF (OK .NEQV. .TRUE.) THEN CALL OUTMSG(' Cannot open the file '// & FULL_NAME_IN(1:NAME_LENGTH_IN)) CALL PFWAIT() GOTO 999 ENDIF C CALL D0OPEN(UNIT_OUT, FULL_NAME_OUT, 'OF', OK) IF (OK .NEQV. .TRUE.) THEN CALL OUTMSG(' Cannot open the file '// & FULL_NAME_OUT(1:NAME_LENGTH_OUT)) CALL PFWAIT() GOTO 999 ENDIF C C Strip the selected sections from the input file C CALL STRIP_LSM(UNIT_IN, UNIT_OUT, UPDT_PRC, UPDT_PTC, UPDT_GEOM, & OK) IF (OK .NEQV. .TRUE.) THEN CALL OUTMSG(' Error reading input file, cannot proceed.') CALL PFWAIT() GOTO 999 ENDIF C C Add the new sections C IF (UPDT_PRC .EQV. .TRUE.) CALL WRITE_CUTS(UNIT_OUT) IF (UPDT_PTC .EQV. .TRUE.) CALL WRITE_SLOPE(UNIT_OUT) IF (UPDT_GEOM .EQV. .TRUE.) THEN CALL OUTMSG(' Updating tower geometry not implemented yet') ENDIF C C Release unit numbers C CLOSE(UNIT_IN) CLOSE(UNIT_OUT) CALL RLUNIT(ROUTINE_ID, UNIT_IN, ERROR) IF (ERROR .NE. 0) CALL ABORT('Error calling RLUNIT in UPDT_LSM') CALL RLUNIT(ROUTINE_ID, UNIT_OUT, ERROR) IF (ERROR .NE. 0) CALL ABORT('Error calling RLUNIT in UPDT_LSM') C C New file name becomes current file name C LSM_DIRECTORY_NAME = REV_DIRECTORY_NAME LSM_REVISION_NUMBER = REVISION_NUMBER_2 LSM_FILE_NAME = REV_FILE_NAME C CALL STAMSG(' File and memory contents updated', .TRUE.) CALL PFWAIT() C 999 RETURN END