CTITLE SARSAVE -- NEW TIME-PICK FILE CREATION ( OPEN, WRITE, AND CLOSE ) C*********************************************************************** C COPYRIGHT ATLANTIC RICHFIELD COMPANY 1991 * C*********************************************************************** CA CA DESIGNER J. V. S. HARVEY CA LANGUAGE VS FORTRAN (77) CA REWRITTEN FAC 27 MAY 1988 1) USE UPNPRM FOR DYNAM ALLOC OF CA PICK FILE CA 2) USE FOSCDK I/O ROUTINES FOR CA OPEN/WRITE/CLOSE OF PICK FILE CA REWRITTEN RDK 2 JUL 1992 ADD CORRECT CARD COUNT, DUMMY CA LINE, AND DATE+TIME TO FILE CA HEADER CARD CA CA CA THIS SUBROUTINE CREATES A NEW (PERMANENT) TIME PICK FILE CA CA CA CALL SARSAVE( SAVOPT, NSHOT, SHOTNO, SHOTID, CA NUMHRZ, LCTPSP, RTIMES, CA NEWDSN, ERR1, ERR2 ) CA CA CA IN/OUT ARGUMENT TYPE DESCRIPTION CA CA IN SAVOPT CH4 PHANTOM PICK INCLUSION FLAG CA 'SAVE' FOR EXCLUSION OF PHANTOMED PICKS CA 'KEEP' INCLUSION OF PHANTOMED PICKS CA CA IN NSHOT I4 NUMBER OF SHOTPOINTS CA IN SHOTNO I2 PICKED SHOTPOINT NUMBER LIST CA ( 1-D ARRAY DIMENSIONED: NSHOT ) CA CA IN SHOTID R4 SHOTPOINT IDENTIFICATION ARRAY CA (1,I) = X COORDINATE (IN-LINE) CA IN UNITS OF GRID-POINT POSITION CA (2,I) = Y COORDINATE (CROSS-LINE) CA IN UNITS OF GRID-POINT POSITION CA (3,I) = SURFACE ELEVATION CA IN ORIGINAL UNITS CA (4,I) = RECIPROCAL RECEIVER NUMBER CA AS INDEX PLUS FRAC. DISTANCE CA (5,I) = EQUIVALENT CDPN LOCATION CA AS INDEX PLUS FRAC. DISTANCE CA ( 2-D ARRAY DIMENSIONED: 5 BY NSHOT ) CA CA CA IN NUMHRZ I4 NUMBER OF HORIZONS IN ANALYSIS CA IN LCTPSP I4 NUMBER OF TRACES PER SHOT CA CA IN RTIMES R4 REFRACTION TIMES IN SECONDS CA SIGN INDICATES SOURCE: CA POSITIVE FOR ORIGINAL PICK CA ZERO FOR MISSING PICK CA NEGATIVE FOR PHANTOMED PICK CA ABSOLUTE VALUE GIVES PROPER TIME CA ( 3-D ARRAY DIMENSIONED: LCTPSP BY NSHOT BY NUMHRZ ) CA CA CA OUT NEWDSN CH8 NEW PICK-FILE DATASET NUMBER CA CA OUT ERR1 I4 ERROR CODE CA 0 FOR NO ERROR CA 2-29 DYNAMIC ALLOCATION ERROR (UPNPRM) CA 30 ERROR INITIALIZING PICK FILE CA 31 ERROR WRITING TO PICK FILE CA 32 ERROR CLOSING PICK FILE CA CA OUT ERR2 I4 CODES FROM DYNAMIC ALLOCATION (SVC 99). CA BYTES 1 AND 2 = ERROR CODE, CA BYTES 3 AND 4 = INFORMATION CODE. CA CA SEE: IBM MANUAL GC28-0627-2 CA OS/VS2 MVS SYSTEM PROGRAMMING LIBRARY , CA JOB MANAGEMENT, PAGES 28 TO 31.0. CA C*********************************************************************** C C SUBROUTINES CALLED: UPNPRM -- DYNAMIC FILE ALLOCATION C FOIWTR -- INITIALIZE NEW DATA SET FOR WRITE C FOWTR -- WRITE RECORD TO NEW DATA SET C FOCWTR -- CLOSE NEW DATA SET C C*********************************************************************** C SUBROUTINE SARSAVE( SAVOPT, NSHOT, SHOTNO, SHOTID, * NUMHRZ, LCTPSP, RTIMES, * NEWDSN, ERR1, ERR2 ) IMPLICIT INTEGER (A-Z) C INTEGER CPUTM CHARACTER*4 SAVOPT INTEGER*2 SHOTNO(NSHOT) REAL SHOTID(5,NSHOT) REAL RTIMES(LCTPSP,NSHOT,NUMHRZ) CHARACTER*8 NEWDSN CHARACTER*8 DATE CHARACTER*8 TIME C====================================================================== C C LOCAL VARIABLES C PARAMETER ( TR1 = 1, TR3 = 0 ) PARAMETER ( IUNIT = 88 ) C CHARACTER*80 CARD CHARACTER*44 DSNAME CHARACTER*8 QUALF1 /'PICK-PH '/ CHARACTER*8 QUALF2 /'PICK-ML '/ C REAL RTIME C REAL ABS C C*********************************************************************** C*** **** C*** COUNT NUMBER OF CARDS (RECORDS) **** C*** **** C*********************************************************************** C NCARD = 1 C DO 190 SHOT = 1, NSHOT DO 175 CURHRZ = 1, NUMHRZ NCARD = NCARD + 1 C C I1 = 1 DO 150 ORTN = 1, LCTPSP, 16 C IF( I1 .GT. 80 ) THEN NCARD = NCARD + 1 C I1 = 1 C ENDIF 150 CONTINUE C C NCARD = NCARD + 1 175 CONTINUE 190 CONTINUE C*********************************************************************** C*** **** C*** ALLOCATE CARD-IMAGE FILE **** C*** **** C*********************************************************************** COADY DSTYP = 1 LRECLB = 80 LRECLW = LRECLB / 4 BLKSIZ = 6160 IF( SAVOPT .EQ. 'KEEP' ) THEN CCC CALL UPNCIF( NCARD, 1, QUALF1, IUNIT, NEWDSN, ERR1, ERR2 ) CALL UPNPRM( NCARD, LRECLB, BLKSIZ, DSTYP, QUALF1, DSNAME, + DCBAD, ERR1, ERR2) ELSE CCC CALL UPNCIF( NCARD, 1, QUALF2, IUNIT, NEWDSN, ERR1, ERR2 ) CALL UPNPRM( NCARD, LRECLB, BLKSIZ, DSTYP, QUALF2, DSNAME, + DCBAD, ERR1, ERR2) ENDIF C CHECK FOR SUCCESSFUL ALLOCATION OF PICK FILE IF( ERR1 .NE. 1 ) THEN WRITE (KPPRNT, 8050) KPNA,KPRNO, ERR1,ERR2 C SET ERROR RETURN FLAG FOR DYNMAIC ALLOCATION ERROR ERR1 = 1 RETURN END IF ERR1 = 0 C C*********************************************************************** C*** **** C*** FIRST CARD **** C*** **** C*********************************************************************** C C SET DATA SET NUMBER PARM NEWDSN) FOR RETURN NEWDSN(1:7) = DSNAME(6:12) C INITIALIZE NEW DATA SET FOR WRITE CALL FOIWTR (DCBAD, LRECLW, ERR) IF (ERR .NE. 1) THEN WRITE(KPPRNT, 8020) DSNAME, ERR ERR1 = 30 RETURN END IF CARD = ' ' C ------------------------------------------- C C NUMBER OF SHOTPOINTS PICKED C WRITE( CARD(1:5), 8000 ) NSHOT C ------------------------------------------- C C INITIAL SHOTPOINT NUMBER C BEGSP = SHOTNO(1) C DO 50 SHOT = 2, NSHOT IF( BEGSP .GT. SHOTNO(SHOT) ) BEGSP = SHOTNO(SHOT) 50 CONTINUE C WRITE( CARD(6:10), 8000 ) BEGSP C ------------------------------------------- C C ENDING SHOTPOINT NUMBER C ENDSP = SHOTNO(1) C DO 75 SHOT = 2, NSHOT IF( ENDSP .LT. SHOTNO(SHOT) ) ENDSP = SHOTNO(SHOT) 75 CONTINUE C WRITE( CARD(11:15), 8000 ) ENDSP C ------------------------------------------- C C MAXIMUM TRACES PER SHOTPOINT PICKED C WRITE( CARD(16:20), 8000 ) LCTPSP C ------------------------------------------- C C TOTAL CARDS IN THIS DATASET C IF (NCARD.LT.100000) * WRITE( CARD(21:25),8000 ) NCARD IF (NCARD.GE.100000) * WRITE( CARD(21:30),8005 ) NCARD C C ------------------------------------------- C C ADD A DUMMY LINE + DATE AND TIME C CARD(51:63) = 'MLRS OUTPUT ' C CALL DATIME( DATE, TIME, CPUTM ) CARD(64:71) = DATE CARD(73:80) = TIME C---------------------------------------------------------------------- C C WRITE THE FIRST DATA RECORD C CALL FOWTR( DCBAD, CARD, LRECLW, ERR) IF ( ERR .NE. 1 ) GO TO 1000 CARD = ' ' C====================================================================== C C FIRST CARD FOR NEW SHOT C DO 390 SHOT = 1, NSHOT DO 380 CURHRZ = 1, NUMHRZ WRITE( CARD(1:5), 8000 ) SHOTNO(SHOT) C ------------------------------------------- C C NUMBER OF HORIZONS C WRITE( CARD(6:10), 8000 ) NUMHRZ C ------------------------------------------- C C CURRENT HORIZON C WRITE( CARD(11:15), 8000 ) CURHRZ C ------------------------------------------- C C FIRST PAIR OF TIME-PICK TRACE RANGES C WRITE( CARD(16:20), 8000 ) TR1 WRITE( CARD(21:25), 8000 ) LCTPSP C C SECOND PAIR OF TIME-PICK TRACE RANGES C WRITE( CARD(26:30), 8000 ) TR3 WRITE( CARD(31:35), 8000 ) TR3 C ------------------------------------------- C C SHOTPOINT COORDINATES C WRITE( CARD(36:45), 8010 ) SHOTID(1,SHOT) WRITE( CARD(46:55), 8010 ) SHOTID(2,SHOT) C---------------------------------------------------------------------- C C WRITE THE FIRST DATA RECORD FOR CURRENT SHOT C CALL FOWTR( DCBAD, CARD, LRECLW, ERR) IF ( ERR .NE. 1 ) GO TO 1000 CARD = ' ' C====================================================================== C C CASE A) SAVE ALL PICKS C IF( SAVOPT .EQ. 'KEEP' ) THEN I1 = 1 DO 350 ORTN = 1, LCTPSP IF( I1 .GT. 80 ) THEN CALL FOWTR( DCBAD, CARD, LRECLW, ERR) IF ( ERR .NE. 1 ) GO TO 1000 CARD = ' ' I1 = 1 ENDIF C RTIME = 1000.0*RTIMES(ORTN,SHOT,CURHRZ) ITIME = ABS( RTIME ) + 0.5 C I2 = I1 + 4 WRITE( CARD(I1:I2), 8000 ) ITIME I1 = I1 + 5 350 CONTINUE C ------------------------------------------- C C CASE B) SAVE ORIGINALS ONLY C ELSE I1 = 1 DO 375 ORTN = 1, LCTPSP IF( I1 .GT. 80 ) THEN CALL FOWTR( DCBAD, CARD, LRECLW, ERR) IF ( ERR .NE. 1 ) GO TO 1000 CARD = ' ' I1 = 1 ENDIF C RTIME = 1000.0*RTIMES(ORTN,SHOT,CURHRZ) ITIME = RTIME + 0.5 C IF( ITIME .LT. 0 ) ITIME = 0 C I2 = I1 + 4 WRITE( CARD(I1:I2), 8000 ) ITIME I1 = I1 + 5 375 CONTINUE ENDIF C---------------------------------------------------------------------- C C WRITE THE NEXT DATA RECORD FOR CURRENT SHOT C CALL FOWTR( DCBAD, CARD, LRECLW, ERR) IF ( ERR .NE. 1 ) GO TO 1000 CARD = ' ' 380 CONTINUE 390 CONTINUE C C*********************************************************************** C*** **** C*** END-OF-FILE **** C*** **** C*********************************************************************** C CALL FOCWTR( DCBAD, ERR) IF (ERR .NE. 1) THEN WRITE(KPPRNT, 8030) DSNAME, ERR ERR1 = 32 RETURN END IF RETURN C*********************************************************************** C*** **** C*** ERROR HANDLING ( FOWTR ) **** C*** **** C*********************************************************************** 1000 WRITE(KPPRNT, 8040) DSNAME, ERR ERR1 = 31 RETURN C*********************************************************************** C*** **** C*** FORMAT STATEMENTS **** C*** **** C ********************************************************************** 8000 FORMAT(I5) 8005 FORMAT(I10) 8010 FORMAT(F10.0) 8020 FORMAT(//5X,'ERROR INITIALIZING PICK FILE FOR OUTPUT'/ + 5X,'PICK FILE DATA SET NAME = ',A44/ + 5X,'ERROR RETURN CODE (FOIWTR) = ',I5) 8030 FORMAT(//5X,'ERROR CLOSING PICK FILE FOR OUTPUT'/ + 5X,'PICK FILE DATA SET NAME = ',A44/ + 5X,'ERROR RETURN CODE (FOCWTR) = ',I5) 8040 FORMAT(//5X,'ERROR WRITING TO PICK FILE'/ + 5X,'PICK FILE DATA SET NAME = ',A44/ + 5X,'ERROR RETURN CODE (FOWTR) = ',I5) 8050 FORMAT(//5X,'DYNAMIC ALLOCATION ERRO FOR PICK FILE FROM ',A4,I1/ + 5X,'ERROR RETURN CODE(FROM UPNPRM) = ',I4/ + 5X,'SVC99 ERROR STATUS CODE = ',Z9) CCC 8080 FORMAT(A80) END