Compass source library.file-id: 'DALAAA20.PEVPSR' SUBROUTINE PEVPSR(TIMTAG,EVSCT,MPAR,MODCOM,REFLAG,CLASS,VETO, * RETGP, RETNO ) C*********************************************************************** C* Institute: MPE * * Subroutine: * C* * * * C* DDDDDD AA LLL * GRO * PEVPSR * C* DDDDDDD AA AA LLL * COMPTEL * * C* DD DD AA AA LLL * * Revision: 5 * C* DD DD AA AA LLL ****************** * C* DD DD AAAAAAAA LLL * * Author: * C* DD DD AAAAAAAA LLL * * Helmut * C* DD DD AA AA LLL * COMPASS * Steinle * C* DD DD AA AA LLL * * * C* DDDDDDD AA AA LLLLLLLL * * Date : * C* DDDDDD AA AA LLLLLLLL * * 1993-09-10 * C* * * * C* Data Access Layer * * * C*********************************************************************** C* Function: Read next record from EVP data set (new version assumed) * C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++* C * C Inputs: * C ======= * C Name Type Description Location * C ------ ----------- ------------------------------------- -------- * C LUNO integer logical unit number to be read from PEVPRI * C VERNO integer data set representation version PEVPRI * C SR logical flag for : PEVPSR is calling routine PWHOL * C RR logical flag for : PEVPRR is calling routine PWHOL * C * C Outputs: * C ======== * C Name Type Description Location * C ------ ----------- ------------------------------------- -------- * C TIMTAG integer (2) time tag (COMPASS point in time) Argument * C EVSCT real (5) event scatter data Argument * C MPAR real (14) main event parameter Argument * C MODCOM integer module combination Argument * C REFLAG integer rejection flag Argument * C CLASS char. *8 classification code Argument * C VETO integer*2 veto flag Argument * C RETGP integer return group Argument * C RETNO integer return number Argument * C SR logical flag for : PEVPSR is calling routine PWHOL * C * C Modified COMMON Variables: * C ========================== * C (only in case a new data set is opened by a call to P9GNDV) : * C COMMON Variable * C ------ -------- * C PEVPRI LUNO * C PEVPRI SERNO * C PEVPRI PVISTA * C PEVPRI PVIEND * C PEVPRI VERNO * C PEVPRC SITE * C PEVPRC HONAME * C (always) : * C PWHOL SR * C * C Calls: * C ====== * C Name Function * C ------ --------------------------------------------- * C CPRINT LUs for print and error * C CERROR more words on errors * C P99RDR read record * C P9GNDV get next data set for read * C PEVPRR read EVP data set record in old format * C TOFCOR TOF corretion (for VERNO < 3) * C * C Needs: nothing special * C ====== * C * C Signals: * C ======== * C RETGP RETNO Meaning * C ----- ----- ------------------------------------------- * C 8 x data set representation number x not valid * C 16 2 invalid processing interval start date/time * C 16 3 invalid processing interval end date/time * C or time sequence out of order * C 23 1 invalid timetag C * C Description: * C ============ * C - read EVP data record * C - de-scale parameter * C * C Documentation : * C =============== * C COM-TN-SYS-SSE-115; issue 2; some notes; * C * C Subroutine History: * C =================== * C Date Id Rev. Changes * C -------- ---- ---- ------------------------------------------- * C 91-01-10 hs 1 first version (from PEVPRR) * C 91-01-29 hs 2 reads also old EVP; rejection flag not * C checked; error handling; * C 91-03-19 hs 3 read of lists with mixed old/new data set * C representations corrected (COMMON PWHOL); * C 92-08-17 RF 4 Allow ver of EVP datatype to be 2 * C 93-08-10 CV 5 TOF corretion for VERNO < 3 * C 93-08-.. RF 5 REFLAG = -2007 if TOFCOR return code not 0 * C 93-09-10 rf 5 Remove REFLAG=-2007, Exempt SIM events from * C TOFCOR * C 95-10-23 RF 6 Check for negative event timtag. Error flag * C*********************************************************************** C IMPLICIT NONE SAVE C----------------------------------------------------------------------- C COMMON BLOCKS C ************* C PEVPRI - Information about EVP data set beeing read (INTEGER) C ============================================================= INTEGER LUNO C \ logical unit number of this dataset INTEGER SERNO C \ serial number of this dataset INTEGER PVISTA(2) C \ start TJD/tick of interval of interest INTEGER PVIEND(2) C \ end TJD/tick of interval of interest INTEGER VERNO C \ data set representation number COMMON /PEVPRI/ LUNO,SERNO,PVISTA,PVIEND,VERNO C--- C PEVPRC - Information about EVP data set beeing read (CHARACTER) C =============================================================== CHARACTER*1 SITE C \ site id CHARACTER*128 HONAME C \ host file name COMMON /PEVPRC/ SITE,HONAME C--- C PWHOL - Information about calling read routine (LOGICAL) C =============================================================== LOGICAL SR C \ PEVPSR in use LOGICAL RR C \ PEVPRR in use COMMON /PWHOL/ SR,RR C----------------------------------------------------------------------- C PEVPD1 - data buffer for unscrambling data record (VERNO = 1) C ============================================================= INTEGER*2 PIT1 C \ point in time TJD INTEGER*2 LOC(8) C \ location information INTEGER*2 MC C \ module combination INTEGER*2 RF C \ rejection flag INTEGER*2 VF C \ veto flag INTEGER PIT2 C \ point in time TICK REAL EN(2) C \ energy REAL PHI C \ phibar REAL CO(4) C \ coordinates REAL EH C \ earth horizon angle CHARACTER*8 CL C \ event class COMMON /PEVPD1/ LOC,MC,RF,VF,PIT1,PIT2,EN,PHI,CO,EH,CL C----------------------------------------------------------------------- C Output variables C ================== CHARACTER*8 CLASS INTEGER*2 VETO INTEGER TIMTAG(2) INTEGER MODCOM INTEGER REFLAG INTEGER RETGP INTEGER RETNO REAL EVSCT(5) REAL MPAR(14) REAL EVSCAT(24) C Local variables C ================= CHARACTER*68 EVBUF1 C \ event buffer for VERNO = 1 data set INTEGER I C \ loop variable INTEGER IDUM C \ TOFCOR return code INTEGER VISTA(2) C \ data set validity interval start TJD/TIC INTEGER VIEND(2) C \ data set validity interval end TJD/TICK INTEGER TIME(2) C \ time (TJD/TICK) INTEGER LUPR C \ logical unit for print output (not used) INTEGER LUERR C \ logical unit for error messages INTEGER RGP C \ error return group from call to CPRINT INTEGER RNO C \ error return number from call to CPRINT INTEGER ERRMSG C \ error message number CHARACTER*3 CTYP C \ first 3 characters of CLASS from EVP (e.g. SIMxxxxx) C----------------------------------------------------------------------- C Initialize variables C ====================== EQUIVALENCE (LOC,EVBUF1) SR = .TRUE. RETGP = 0 RETNO = 0 C======================================================================= C--- Executable statements C ======================= C-- read data from currently open dataset 1 CONTINUE IF (VERNO.LT.0.OR.VERNO.GT.3) THEN ERRMSG = 9002 GO TO 9000 END IF IF (VERNO.GE.1) THEN 2 CONTINUE CALL P99RDR(LUNO,0,EVBUF1,RETGP,RETNO) IF (RETGP.EQ.0) GO TO 4 IF (RETGP.NE.5) THEN ERRMSG = 9003 GO TO 9000 END IF 3 CONTINUE C- Attempt to open next data set in the list IF (SR.AND.RR) THEN SR = .FALSE. GO TO 9999 END IF CALL P9GNDV(LUNO,SITE,SERNO,VISTA,VIEND,HONAME,VERNO, * RETGP,RETNO) IF (RETGP.NE.0) THEN ERRMSG = 9004 GO TO 9000 END IF GO TO 1 4 CONTINUE C- check if current event timetag is negative. If so , error. C IF((PIT1 .LT. 0).OR.(PIT2 .LT. 0).OR.(PIT2 .GT. 691199999))THEN ERRMSG = 9007 GO TO 9000 ENDIF C- Check if current record is before requested start time and C if so go read the next one TIME(1) = PIT1 TIME(2) = PIT2 IF (TIME(1).LT.PVISTA(1).OR. * (TIME(1).EQ.PVISTA(1).AND.TIME(2).LT.PVISTA(2))) GO TO 2 C- If time of current record is later then requested return EOF IF (TIME(1).GT.PVIEND(1).OR. * (TIME(1).EQ.PVIEND(1).AND.TIME(2).GT.PVIEND(2))) THEN ERRMSG = 9005 GO TO 9000 END IF C-- De-scale parameter and transform from INTEGER*2 to C argument spec C Copy data from COMMON PEVPD1 to return variables TIMTAG(1) = TIME(1) TIMTAG(2) = TIME(2) MPAR( 1) = EN(1) MPAR( 2) = EN(2) MPAR( 3) = EN(1) + EN(2) MPAR( 4) = 0 MPAR( 5) = PHI MPAR( 6) = 0 MPAR( 7) = LOC(1)/32. MPAR( 8) = LOC(2)/32. MPAR( 9) = LOC(3)/256. MPAR(10) = LOC(4)/32. MPAR(11) = LOC(5)/32. MPAR(12) = LOC(6)/256. MPAR(13) = LOC(7)/128. MPAR(14) = LOC(8)/128. CLASS = CL MODCOM = MC REFLAG = RF VETO = VF EVSCT(1) = CO(1) EVSCT(2) = CO(2) EVSCT(3) = CO(3) EVSCT(4) = CO(4) EVSCT(5) = EH CTYP = CLASS(1:3) C C Now do the TOF correction for dataset versions < 3 C IF(VERNO.LT.3)THEN C C Do not correct for SIM events C IF (CTYP .NE. 'SIM') THEN IF (REFLAG .GE. 4) THEN CALL TOFCOR(MPAR(1),MPAR(2),MPAR(14),IDUM) ENDIF ENDIF ENDIF ELSE CALL PEVPRR(TIMTAG,EVSCAT,MPAR,CLASS,MODCOM,RETGP,RETNO) IF (RETGP.NE.0) THEN IF (RETGP.EQ.5) GO TO 3 ERRMSG = 9006 GO TO 9000 END IF REFLAG = 0 VETO = 0 EVSCT(1) = EVSCAT(1) EVSCT(2) = EVSCAT(2) EVSCT(3) = EVSCAT(5) EVSCT(4) = EVSCAT(6) EVSCT(5) = EVSCAT(9) END IF GO TO 9999 C*********************************************************************** C**** error handling *************************************************** 9000 CONTINUE C-- get LU numbers for print and errors CALL CPRINT(LUPR,LUERR,RGP,RNO) IF (RGP.NE.0) THEN RETGP = RGP RETNO = RNO ERRMSG = 9001 END IF C-- calculate GO TO address for error message ERRMSG = ERRMSG - 9000 GO TO (9001,9002,9003,9004,9005,9006,9007) ERRMSG C-- error messages : 9001 CONTINUE WRITE(*,'(/,1X,71(''*''),/,'' PEVPSR (9001) :'', * '' non-zero ERROR return from CALL to CPRINT'',/,16X, * '' The error returns from CPRINT are RGP and RNO.'',/,16X, * '' The error returns that caused the call to CPRINT'', * '' are unchanged, but can not be printed normally. '')') WRITE(*,*) ' RGP : ', RGP WRITE(*,*) ' RNO : ', RNO WRITE(*,*) ' RETGP : ', RETGP WRITE(*,*) ' RETNO : ', RETNO WRITE(* ,'(1X,71(''*''),/)') GO TO 9999 9002 CONTINUE WRITE(LUERR,'(/,1X,71(''*''),/,'' PEVPSR (9002) :'', * '' data set representation version invalid '')') WRITE(LUERR,*) ' VERNO : ', VERNO RETGP = 8 RETNO = VERNO GO TO 9998 9003 CONTINUE WRITE(LUERR,'(/,1X,71(''*''),/,'' PEVPSR (9003) :'', * '' non-zero ERROR return from CALL to P99RDR'')') WRITE(LUERR,'(1X,71(''*''),/)') GO TO 9999 9004 CONTINUE WRITE(LUERR,'(/,1X,71(''*''),/,'' PEVPSR (9004) :'', * '' non-zero ERROR return from CALL to P9GNDV '')') WRITE(LUERR,*) ' LUNO : ', LUNO WRITE(LUERR,'(1X,71(''*''),/)') GO TO 9999 9005 CONTINUE WRITE(LUERR,'(/,1X,71(''*''),/,'' PEVPSR (9005) :'', * '' time of record after interval of interest '',/,16X, * '' => end of EVP data '')') RETGP = 5 RETNO = 1 WRITE(LUERR,'(1X,71(''*''),/)') GO TO 9999 9006 CONTINUE WRITE(LUERR,'(/,1X,71(''*''),/,'' PEVPSR (9006) :'', * '' non-zero ERROR return from CALL to PEVPRR '')') WRITE(LUERR,'(1X,71(''*''),/)') GOTO 9998 9007 CONTINUE WRITE(LUERR,'(/,1X,71(''*''),/,'' PEVPSR (9007) :'', * '' Negative timetag on EVP dataset after '',I6,I10)') * TIME(1),TIME(2) RETGP = 23 RETNO = 1 GO TO 9999 9998 CONTINUE CALL CERROR(LUERR,RETGP,RETNO) WRITE(LUERR,'(1X,71(''*''),/)') C**** end error handling - return to calling program ******************* C*********************************************************************** 9999 CONTINUE RETURN END