SUBROUTINE PDS_Keywords( PROD ) C C---------------------------------------------------------------------- C C.IDENTIFICATION: Subroutine PDS_Keywords (PDS keywords management) C.AUTHOR: L. Nicastro - ITeSRE/CNR, Bologna. C.VERSIONS: 0.1 - 20 June 96 - Original version (from PDS_K) C 0.2 - 05 July 96 - Added PRODUCT parameter. C 0.3 - 29 July 96 - Check for PDSCALIB env. variable C 0.4 - 12 Sep 96 - Removed data check for PDS_FOTUNITS C 0.5 - 02 Dec 96 - code for HK is H not K (LC & DDF) C 0.6 - 13 Jan 97 - Removed set of BINSIZE and TIMEZERO. C Added check for COUNTAXIS. C Fixed pckt lookup for dir007-14. C 0.7 - 08 Jul 97 - Added PSACORR keyword. C 0.8 - 02 Sep 97 - Added LUINST close statement. C Changed PSACORR setting. C 0.9 - 25 Sep 97 - changed the name of the LOCAL common C.PURPOSE: Transfers all the PDS keywords. FOT data. C.METHOD: read COMMON blocks and ASCII files (EXCONF,...) for FOT C. data files. C.SYNTAX: CALL PDS_Keywords( PRODUCT ) C.ARGUMENTS: PRODUCT: (char) The product type: S (spectrum), T (time C series, I (image), P (photon list), C H (housekeeping), M (matrix) C.RESTRICTIONS: C.NOTES: No operation is performed if PRODUCT is not recognised. C.FILES: C.REFERENCES: C C---------------------------------------------------------------------- C INCLUDE 'hcommon.inc' INCLUDE 'bincommon.inc' INCLUDE 'accumcommon.inc' INCLUDE 'context.inc' INCLUDE 'timecommon.inc' INCLUDE 'opcommon.inc' c. INCLUDE 'pdsnaipsa.inc' * c. INCLUDE 'pcktcommon.inc' CHARACTER STARTHEX*10,ENDHEX*10,SLEW,INSSLEW INTEGER NDIMENS, NFORMAT, IN2, ITYPE, IDUMMY INTEGER IOBS,INSOBS REAL SSEC,ESEC REAL DMIN,DMAX * C--> this should be in a common block... * CHARACTER STUFF(ACCUMCOMMON_MAXDIM)*16 CHARACTER XSTUFF(BINCOMMON_MAXFIELDS)*16 DATA STUFF /ACCUMCOMMON_MAXDIM*'unspecified '/ DATA XSTUFF /BINCOMMON_MAXFIELDS*'undefined '/ *- CHARACTER PRODUCT,PROD*(*) CHARACTER UNITS*8,COIN*3,PRODUCT2*1 INTEGER TRUE_LENGTH C CHARACTER INSTR*4,INSTREC*133,DUMMY CHARACTER BUFFER*(80),BUFFER2*(82),PREPARSE*(82) CHARACTER*80 FILEROOT,FILEIN,FILEINST CHARACTER*20 FIELDNAME,FIELDQUERY,FILEINST0 CHARACTER FIELD*2,CALON*3,CAXIS*1 INTEGER IERR,I,NUNITS,INDX(2),IU,IC,NU,LFR,LUINST INTEGER IXNEWS,IEL(4),IEH(4), IPDIR,INDIR INTEGER I70,ZC_TIME,IVOS,ISYS REAL*8 DJM,BMJD ! ,BTBMJD LOGICAL VOSERROR,FOUND,btest C DATA IEL,IEH /4*0,4*0/ C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C--> Pseudo-images specific (from "saxgaccum")... to be implemented REAL*4 BASEI(1) INTEGER ISIZEI,IADDRI,IOFFI,IXNEWI,IYNEWI C COMMON /LOCAL/ ISIZEI,IADDRI,IOFFI,IXNEWI,IYNEWI,BASEI COMMON /LOCAL_IMG/ ISIZEI,IADDRI,IOFFI,IXNEWI,IYNEWI,BASEI *-- * C-- Check PRODUCT is valid. * c. CALL GET_GLOBAL_DEFAULT( 'CONTEXT','S',PRODUCT ) PRODUCT=PROD(1:1) IF (PRODUCT.NE.'S' .AND. PRODUCT.NE.'T' .AND. PRODUCT.NE.'I' . .AND. PRODUCT.NE.'P' .AND. PRODUCT.NE.'H' . .AND. PRODUCT.NE.'M') THEN WRITE (6,*) 'PDS_Keywords: Invalid product.' RETURN ENDIF * C-- Get root file name (should be in a common block!) * CALL SAX_FROOT_NAME( FILEROOT ) LFR = TRUE_LENGTH( FILEROOT ) FILEIN = FILEROOT(:LFR)//'.'//ACCUMCOMMON_PACKET * C-- Get header info from first packet * c. CALL PDS_PCKT( 33,FILEIN ) C C-- re-load basic information about the packet (should be in a common block!) C CALL SAX_ACC_PRELOAD( NDIMENS,NFORMAT,XSTUFF,STUFF ) * C--> encode selected PHW units into UNITS. Not fully implemented... * c. IF (PCKTCOMMON_PKTYP.EQ.'DIR' .OR. c. . PCKTCOMMON_PKTYP.EQ.'ENG') CALL PDS_UNITS( STUFF,IERR ) c. IF (INDEX(ACCUMCOMMON_PACKET,'dir').NE.0 .OR. c. . INDEX(ACCUMCOMMON_PACKET,'lat').NE.0 .OR. c. . INDEX(ACCUMCOMMON_PACKET,'psa').EQ.0 .OR. c. . INDEX(ACCUMCOMMON_PACKET,'cal').EQ.0 .OR. c. . INDEX(ACCUMCOMMON_PACKET,'eng').NE.0) CALL PDS_FOTUNITS( STUFF,UNITS,IERR ) * C current date in MJD format (provisional) I70 = ZC_TIME() CALL TIME_70S2MJD( I70,DJM,IERR ) C C Initialize keywords C PRODUCT2 = PRODUCT IF (PRODUCT2.EQ.'H') PRODUCT2 = 'T' CALL INSTRUMENT_KEYS( PRODUCT2,12 ) * C-- keywords common to any product... * CALL INST_KEY_SET( 'ORIGIN','XAS ',1,1,IERR ) C identify parent file CALL INST_KEY_SET( 'PARENTS', . '1 '//FILEIN(:TRUE_LENGTH(FILEIN)),1,1,IERR ) c. CALL INST_KEY_SET( 'COMMENT', c. . 'Data type: '//PCKTCOMMON_FILEDESC,1,1,IERR ) * CALL INST_KEY_SET( 'PDSDATE',DJM,1,1,IERR ) * C-- Get obs. date form INSTDIR file * C retrieve instrument from context CALL GET_GLOBAL_DEFAULT( 'INSTRUMENT','NONE',INSTR ) BMJD = 0. FILEINST0 = INSTR(1:2)//'.instdir' CALL BUILDPATH( FILEINST0,'FOT',FILEINST ) CALL FREE_LU( LUINST ) CALL Z_OPEN( LUINST,FILEINST,'SEQ','OLD',0 ) IF (VOSERROR(IVOS,ISYS)) THEN WRITE (6,*) 'PDS_Keywords: Error reading INSTDIR file.' RETURN ENDIF * CALL GET_GLOBAL_DEFAULT( 'SLEW','n',SLEW ) CALL LOWCASE( SLEW ) CALL GET_OBS_CHAIN( IOBS,'Reset' ) * 1 CONTINUE C C read and decode intrument directory record sequentially READ (LUINST,'(A)',END=899) INSTREC CALL REARRANGE_INSTREC( INSTREC ) READ (INSTREC,*,IOSTAT=IERR) DUMMY,(STARTARR(I),I=1,5),SSEC, . STARTHEX,(ENDARR(I),I=1,5),ESEC,ENDHEX,INSSLEW,INSOBS C C are we on the wished record ? CALL LOWCASE( INSSLEW ) IF (INSSLEW .NE. SLEW) GOTO 1 IF (INSOBS .NE. IOBS) GOTO 1 C C Yes we are, so ... CLOSE ( LUINST ) C we can store and decode start and end times STARTARR(6) = SSEC STARTARR(7) = SSEC/100. ENDARR(6) = ESEC ENDARR(7) = ESEC/100. CALL TIME_1970( STARTARR,I70 ) CALL TIME_70S2MJD( I70,BMJD,IERR ) * 899 CALL INST_KEY_SET( 'PDSDTOBS',BMJD,1,1,IERR ) C--> Coincidence flags COIN = 'FFF' C--> Decode DIR mode INDIR = 0 IPDIR = INDEX(ACCUMCOMMON_PACKET,'dir') IF (IPDIR .NE. 0) THEN IPDIR = IPDIR + 3 READ (ACCUMCOMMON_PACKET(IPDIR:IPDIR+2),*) INDIR IF (INDIR .LE. 2) THEN c.. IF (INDEX(ACCUMCOMMON_PACKET,'dir001').NE.0 .OR. c.. . INDEX(ACCUMCOMMON_PACKET,'dir002').NE.0) THEN IN2 = 0 DO 100 I=1,ACCUMCOMMON_NF WRITE (FIELD,201) I 201 FORMAT ('f',I1) CALL PKTCAP_LOOKUP( FIELD,ITYPE,IDUMMY,FIELDNAME,FOUND ) IF (FIELDNAME(1:TRUE_LENGTH(FIELDNAME)).EQ.'Flags') THEN IN2 = I GOTO 110 ENDIF 100 CONTINUE 110 CONTINUE IF (IN2 .EQ. 0) THEN WRITE (6,202) 202 FORMAT ('PDS_Keywords: Error in packetcap field names!') CALL Z_EXIT( 1 ) ENDIF DO 15 I=1,3 15 WRITE (COIN(I:I),'(L1)') btest(ACCUMCOMMON_IEH(IN2),I-1) ENDIF ENDIF CALL INST_KEY_SET( 'PDSCOIN',COIN,1,1,IERR ) *-- End keywords common to any product... C-- Check if Rate or Counts ... CALL GET_GLOBAL_DEFAULT( 'COUNTAXIS','R',CAXIS ) CALL UPCASE( CAXIS ) * C-- keywords common to all * c. IF (PRODUCT.NE.'A') THEN CALL INST_KEY_SET( 'DATE',DJM,1,1,IERR ) CALL INST_KEY_SET( 'DATE_OBS',BMJD,1,1,IERR ) CALL INST_KEY_SET( 'SCSTART',TIMECOMMON_START,1,1,IERR ) CALL INST_KEY_SET( 'SCEND',TIMECOMMON_END,1,1,IERR ) * CALL INST_KEY_SET( 'PDSUNITS',UNITS,1,1,IERR ) c. CALL INST_KEY_SET( 'PDSMODID',PCKTCOMMON_IPCKT,1,1,IERR ) c. CALL INST_KEY_SET( 'PDSPKTID',PCKTCOMMON_IPCKT,1,1,IERR ) c. ENDIF * C-- keywords common to all but pseudo-images... * IF (PRODUCT.NE.'I') THEN CALL INST_KEY_SET( 'STORAGE','BYROW',1,1,IERR ) ENDIF * C-- keywords common to spectra and pseudo-images... * IF (PRODUCT.EQ.'S' .OR. PRODUCT.EQ.'I') THEN CALL INST_KEY_SET( 'EXPOSURE',TIMECOMMON_LIVE,1,1,IERR ) * CALL INST_KEY_SET( 'DEADTIME','FIXED',1,1,IERR ) CALL INST_KEY_SET( 'DTVALUE',TIMECOMMON_DEAD,1,1,IERR ) CALL INST_KEY_SET( 'DTCORR','NOT APPLIED',1,1,IERR ) * C-- Get PDS high voltages, temperatures and status keywords from external file * CALL PDSHKK( FILEROOT, IERR ) ENDIF * C-- Manual input for the remaining keywords? (temporary) * CALL GET_GLOBAL_DEFAULT('PDSCALIB',' ',CALON) IF (CALON.EQ.'ON') THEN CALL X_PROMPT( ' Enter PDSCALID: ',0 ) CALL X_READ( 0,1,BUFFER ) BUFFER2 = PREPARSE( BUFFER ) READ (BUFFER2,*,IOSTAT=IERR) BUFFER CALL INST_KEY_SET( 'PDSCALID',buffer(:6),1,1,IERR ) IF (IERR .NE. 0) WRITE (6,*) 'Warning! Error =',IERR CALL X_PROMPT( ' Enter PDSSPCOD: ',0 ) CALL X_READ( 0,1,BUFFER ) BUFFER2 = PREPARSE( BUFFER ) READ (BUFFER2,*,IOSTAT=IERR) BUFFER CALL INST_KEY_SET( 'PDSSPCOD',BUFFER(:6),1,1,IERR ) IF (IERR .NE. 0) WRITE (6,*) 'Warning! Error =',IERR C--> To be continued below? ENDIF * C-- remaining PRODUCT specific keywords * C-- Spectra (assume one spectrum per file...) IF (PRODUCT.EQ.'S') THEN C Counts or Rate (default = Rate) c.. IF (CAXIS.EQ.'C') THEN c.. CALL INST_KEY_SET( 'TUNIT3','CTS',1,1,IERR ) c.. CALL INST_KEY_SET( 'TUNIT4','CTS',1,1,IERR ) c.. ENDIF C ixnew is number of bins IXNEWS=ACCUMCOMMON_IEH(ACCUMCOMMON_IXINDEX(1)) - . ACCUMCOMMON_IEL(ACCUMCOMMON_IXINDEX(1)) + 1 IXNEWS=IXNEWS/ACCUMCOMMON_IXZOOM(1) * BUFFER2 = STUFF(ACCUMCOMMON_IXINDEX(1)) I=TRUE_LENGTH(BUFFER2) CALL INST_KEY_SET( 'PDSSTYPE',BUFFER2(:I),1,1,IERR ) * C-- First accumulation range is always X-axis quantity. C-- At the moment distinguish only PHA and RiseTime accumulations * c.. IF (INDEX(ACCUMCOMMON_PACKET,'dir').EQ.0) THEN IF (INDIR.EQ.0 .OR. INDIR.GE.7) THEN IU = ICHAR(UNITS(1:1)) - 64 IEL(IU) = 0 IEH(IU) = 1023 ELSE IF (BUFFER2(1:8).EQ.'RiseTime') THEN FIELDQUERY = 'PHA' ELSE FIELDQUERY = 'RiseTime' ENDIF IN2 = 0 DO 200 I=1,ACCUMCOMMON_NF WRITE (FIELD,201) I CALL PKTCAP_LOOKUP( FIELD,ITYPE,IDUMMY,FIELDNAME,FOUND ) IF (FIELDNAME(1:TRUE_LENGTH(FIELDNAME)) .EQ. * FIELDQUERY(1:TRUE_LENGTH(FIELDQUERY))) THEN IN2=I GOTO 210 ENDIF 200 CONTINUE 210 CONTINUE IF (IN2 .EQ. 0) THEN WRITE (6,202) CALL Z_EXIT( 1 ) ENDIF IF (UNITS(:3).EQ.'ALL') THEN DO 25 I=1,4 IEL(I) = ACCUMCOMMON_IEL(IN2) IEH(I) = ACCUMCOMMON_IEH(IN2) 25 CONTINUE ELSE IF (UNITS(:3).EQ.'SUM') THEN IC = 4 NU = TRUE_LENGTH(UNITS) - 4 ELSE IC = 0 NU = 1 ENDIF * DO 35 I=1,NU IU = ICHAR(UNITS(I+IC:I+IC)) - 64 IEL(IU) = ACCUMCOMMON_IEL(IN2) IEH(IU) = ACCUMCOMMON_IEH(IN2) 35 CONTINUE ENDIF ENDIF CALL INST_KEY_SET( 'PDSLOTHR',IEL,1,1,IERR ) CALL INST_KEY_SET( 'PDSUPTHR',IEH,1,1,IERR ) ENDIF C-- Pseudo-images IF (PRODUCT.EQ.'I') THEN CALL INST_KEY_SET( 'BUNIT','COUNTS',1,1,IERR ) NUNITS = TRUE_LENGTH(UNITS) IF (INDEX(UNITS,'SUM') .NE. 0) NUNITS = NUNITS - 4 CALL INST_KEY_SET( 'NAXIS3',NUNITS,1,1,IERR ) C Min and Max... CALL RMINMAX( BASEI(1+IOFFI),ISIZEI,-1.E6,INDX,DMIN,DMAX,IERR ) CALL INST_KEY_SET( 'DATAMIN',DMIN,1,1,IERR ) CALL INST_KEY_SET( 'DATAMAX',DMAX,1,1,IERR ) ENDIF C-- Time profiles c. IF (PRODUCT.EQ.'T' .OR. PRODUCT.EQ.'H') THEN C--> units are provisional IF (PRODUCT.EQ.'T') THEN c. CALL INST_KEY_SET( 'TTYPE1','TIME',1,1,IERR ) c. CALL INST_KEY_SET( 'TTYPE2','DEADTIME',1,1,IERR ) c. CALL INST_KEY_SET( 'TTYPE3','DATA',1,1,IERR ) c. CALL INST_KEY_SET( 'TTYPE4','ERROR',1,1,IERR ) c. CALL INST_KEY_SET( 'TUNIT1','s',1,1,IERR ) c. CALL INST_KEY_SET( 'TUNIT2','fraction',1,1,IERR ) CALL INST_KEY_SET( 'ERROR','COLUMN',1,1,IERR ) CALL INST_KEY_SET( 'ENLOTHR', . ACCUMCOMMON_IEL(ACCUMCOMMON_IXINDEX(1)),1,1,IERR ) CALL INST_KEY_SET( 'ENUPTHR', . ACCUMCOMMON_IEH(ACCUMCOMMON_IXINDEX(1)),1,1,IERR ) CALL INST_KEY_SET( 'PDSSLTHR', . ACCUMCOMMON_IEL(ACCUMCOMMON_IXINDEX(2)),1,1,IERR ) CALL INST_KEY_SET( 'PDSSUTHR', . ACCUMCOMMON_IEH(ACCUMCOMMON_IXINDEX(2)),1,1,IERR ) IF (CAXIS.EQ.'C') THEN CALL INST_KEY_SET( 'TUNIT3','CTS ',1,1,IERR ) CALL INST_KEY_SET( 'TUNIT4','CTS ',1,1,IERR ) ELSE CALL INST_KEY_SET( 'TUNIT3','CTS/'// . TIMECOMMON_UNITS,1,1,IERR ) CALL INST_KEY_SET( 'TUNIT4','CTS/'// . TIMECOMMON_UNITS,1,1,IERR ) ENDIF c. ELSE c. CALL SAX_PCF_LOOKUP( 'un',IDUM,IDUM,HKUNITS,FOUND ) c. CALL INST_KEY_SET( 'TUNIT2',HKUNITS,1,1,IERR ) c. CALL INST_KEY_SET( 'ERROR','POISSON',1,1,IERR ) ENDIF IF (PRODUCT.EQ.'T' .OR. PRODUCT.EQ.'H') THEN CALL INST_KEY_SET( 'BADDATA',-1.E4,1,1,IERR ) ENDIF C-- Photon lists c. IF (PRODUCT.EQ.'P') THEN c. ENDIF C-- ASCII tables c. IF (PRODUCT.EQ.'A') THEN c. ENDIF C-- Matrices c. IF (PRODUCT.EQ.'M') THEN c. ENDIF C-- Add PDSCORR keyword for products from direct mode IF (INDIR.NE.0) THEN IF (ACCUMCOMMON_CORRECT) THEN CALL INST_KEY_SET( 'PSACORR','TRUE',1,1,IERR ) c. WRITE (BUFFER,111) NREJ,FLOAT(NREJ)/ c. . (ACCUMCOMMON_TOTPKT*ACCUMCOMMON_NREC) c. 111 FORMAT (I10,' filtered events (',F5.3,' of the total)') c. CALL INST_KEY_SET( 'COMMENT',BUFFER,1,1,IERR ) ELSE CALL INST_KEY_SET( 'PSACORR','FALSE',1,1,IERR ) ENDIF ENDIF * C-- Flushing keywords to disk * CALL INST_KEY_FLUSH( 1 ) * RETURN END *======== SUBROUTINE PDSHKK( FILEROOT, IERR ) * INTEGER LROW PARAMETER (LROW = 80) ! Max row length INTEGER*4 VALI(12),TRUE_LENGTH INTEGER IERR, ISEPV, KUN, IK, IS, IA, IB, I, IC REAL*4 VALR(5) REAL*8 VALD(2) CHARACTER FILEROOT*(*),EXT*3,SEP*3,SEPV*2,ROW*(LROW+2) * c. INCLUDE 'pcktcommon.inc' *-- DATA EXT /'.HK'/, SEP /' = '/, SEPV /', '/, ISEPV / 2 / *-- KUN = 17 OPEN (KUN,FILE=FILEROOT(1:TRUE_LENGTH(FILEROOT))//EXT, . STATUS='OLD',IOSTAT=IERR) IF (IERR .NE. 0) RETURN * 5 FORMAT (A) 10 READ (KUN,5,END=1000,ERR=1000) ROW ROW = ROW(2:) ! Streeps out the blank in first column IK = INDEX(ROW,SEP) - 1 c KEYNAME = ROW(:IK) IS = IK + 4 IF (INDEX(ROW(IS:),'.') .EQ. 0) THEN ! Integers or String IA = INDEX(ROW,CHAR(39)) ! ' enclose string IF (IA .NE. 0) THEN ! String IA = IA + 1 IB = INDEX(ROW(IA:),CHAR(39)) - 2 CALL INST_KEY_SET(ROW(1:IK),ROW(IA:IA+IB),1,1,IERR) GOTO 10 ELSE ! Integers I = 0 ROW(81:82) = SEPV 50 IC = INDEX(ROW(IS:),SEPV) IF (IC .EQ. 0) GOTO 10 ! end of values I = I + 1 READ (ROW(IS:IS+IC-2),*) VALI(I) IS = IS + IC + 1 IF (IS .GE. LROW) THEN CALL INST_KEY_SET(ROW(1:IK),VALI(1),1,1,IERR) GOTO 10 ENDIF GOTO 50 ENDIF ELSE ! Reals IF (ROW(1:4).EQ.'PDSD' .OR. ROW(1:4).EQ.'DATE') THEN ! Dates are double READ (ROW(IS:),*) VALD(1) CALL INST_KEY_SET(ROW(1:IK),VALD(1),1,1,IERR) GOTO 10 ELSE ! Real*4 I = 0 ROW(81:82) = SEPV 60 IC = INDEX(ROW(IS:),SEPV) IF (IC .EQ. 0) GOTO 10 ! end of values I = I + 1 READ (ROW(IS:IS+IC-2),*) VALR(I) IS = IS + IC + 1 IF (IS .GE. LROW) THEN CALL INST_KEY_SET(ROW(1:IK),VALR(1),1,1,IERR) GOTO 10 ENDIF GOTO 60 ENDIF ENDIF * 1000 CLOSE (KUN) RETURN END