SUBROUTINE INIT_CORRECT_PDS * C---------------------------------------------------------------------- C C.IDENTIFICATION: Subroutine INIT_CORRECT_PDS C.LIBRARY: PDSLIB C.AUTHOR: L. Nicastro - TeSRE Bologna C.VERSIONS: 0.0 - 25 Dec 96 - Dummy version C 0.1 - 11 Mar 97 - Original version C 0.2 - 25 Sep 97 - Commented the private version of C RESET_TABLE_DESC (using the mecslib C version in me_gain_time.f) C 0.3 - 30 Sep 97 - Use BUILDPATH to point calib. dir. C 0.4 - 12 Dec 97 - Added END kwd for the pha_psa.dat read stat. C.PURPOSE: Load NaI PSA peak position for PDS correction C C.METHOD: C.SYNTAX: Called only by INIT_CORRECT C C.PARAMETERS: None. C.RESTRICTIONS: Temporarely use a fixed temperature through the obs. C.NOTES: C.FILES: PDS calibration file "pha_psa.dat" in $MYCALDIR C (def. $XASTOP/calib/sax/pds) and temperature file C for current obs. "tempw1.time" C.REFERENCES: C---------------------------------------------------------------------- * INCLUDE 'accumcommon.inc' INCLUDE 'timecommon.inc' INCLUDE 'opcommon.inc' INCLUDE 'hcommon.inc' INCLUDE 'bincommon.inc' INCLUDE 'syscommon.inc' INCLUDE 'pdsnaipsa.inc' * LOGICAL VOSERROR,LOP * INTEGER*4 NPHADEF, NPSADEF PARAMETER ( NPHADEF = 1024, NPSADEF = 512 ) * INTEGER*4 IVOS,ISYS,IER,IUN,I,J,IPDIR,INDIR,TRUE_LENGTH, . ITYPE,IDUMMY,IPHA,LPHA,IPSA,LPSA, SAVED INTEGER*4 NAXIS1,NT,NFIELDS,IZOFF,START70,DAY70 REAL*8 TJ,T0,UDOUBLE CHARACTER*80 FPHAPSA,XASTOP,NAMETF,BUFFER CHARACTER*20 FIELDNAME CHARACTER FIELD*2,FCAL*11,FTEMPS*11 LOGICAL FOUND *-- * DATA FCAL,FTEMPS /'pha_psa.dat','tempw1.time'/, . TEMPEX /.TRUE./ *------------------------- C-- redundant : shall never be called as such IF (.NOT.ACCUMCOMMON_CORRECT) THEN WRITE (*,*) CHAR(7)// . 'INIT_CORRECT_PDS: ACCUMCOMMON_CORRECT is false.' RETURN ENDIF * C-- Also check the only interesting field "RiseTime" is present C-- (see init_correct.f). * DO 1 I=1,ACCUMCOMMON_NF IF (ACCUMCOMMON_CORRINDX(I) .NE. 0) GOTO 2 1 CONTINUE * WRITE (*,*) CHAR(7)// . 'INIT_CORRECT_PDS: "RiseTime" field not present.' WRITE (*,*) 'INIT_CORRECT_PDS: ACCUMCOMMON_CORRECT set to false.' ACCUMCOMMON_CORRECT = .FALSE. RETURN * 2 CONTINUE * 5 FORMAT (A) * CALL GET_GLOBAL_DEFAULT( 'XASTOP',' ',XASTOP ) IF (XASTOP.EQ.' ') THEN WRITE (*,*) CHAR(7)//'INIT_CORRECT_PDS: XASTOP undefined.' GOTO 999 ENDIF * C--> This is temporary do 550 i=1,ntemp TEMPS(i) = 18.0 TTEMPS(i) = 9d4 550 continue * 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 ELSE WRITE (*,*) CHAR(7)//'INIT_CORRECT_PDS: Invalid packet type.'// . 'INIT_CORRECT_PDS: ACCUMCOMMON_CORRECT set to false.' ACCUMCOMMON_CORRECT = .FALSE. RETURN ENDIF * C-- Get the TIME, PHA, RiseTime and Unit fields * DO 200 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.'TIME') THEN ITIMEF = I ELSE IF (FIELDNAME(1:TRUE_LENGTH(FIELDNAME)).EQ.'PHA') THEN IPHAF = I ELSE IF (FIELDNAME(1:TRUE_LENGTH(FIELDNAME)).EQ.'RiseTime') THEN IPSAF = I ELSE IF (FIELDNAME(1:TRUE_LENGTH(FIELDNAME)).EQ.'Unit') THEN IUNITF = I ENDIF 200 CONTINUE * C-- Get # of PHA and PSA channels * WRITE (FIELD,202) IPHAF 202 FORMAT ('m',I1) CALL PKTCAP_LOOKUP( FIELD,ITYPE,IPHA,FIELDNAME,FOUND ) WRITE (FIELD,203) IPHAF 203 FORMAT ('M',I1) CALL PKTCAP_LOOKUP( FIELD,ITYPE,LPHA,FIELDNAME,FOUND ) NPHAFAC = NPHADEF / (LPHA - IPHA + 1) WRITE (FIELD,202) IPSAF CALL PKTCAP_LOOKUP( FIELD,ITYPE,IPSA,FIELDNAME,FOUND ) WRITE (FIELD,203) IPSAF CALL PKTCAP_LOOKUP( FIELD,ITYPE,LPSA,FIELDNAME,FOUND ) NPSAFAC = NPSADEF / (LPSA - IPSA + 1) c write(6,*)NPHAFAC,NPSAFAC,IUNITF,IPHAF,IPSAF,INDIR * C-- Inquire which I/O unit is free * DO 55 I=10,99 INQUIRE (UNIT=I,OPENED=LOP) IF (.NOT. LOP) GOTO 56 55 CONTINUE 56 IUN = I * C-- Build the temperature array rebinned to 64 s (use only unit A) * CALL BUILDPATH( FTEMPS,'DATA',NAMETF ) SAVED = SYSCOMMON_ICONV CALL OPEN_TIME( IUN,NAMETF,NAXIS1,NT,NFIELDS,IZOFF ) c write(6,*)IUN,NAXIS1,NT,NFIELDS,IZOFF IF (VOSERROR(IVOS,ISYS) .OR. NT.LE.0) THEN WRITE (*,66) CHAR(7),FTEMPS 66 FORMAT (A,'INIT_CORRECT_PDS: Error opening temperature file "', . A,'" in DATADIR.'/,'Assuming T=18 C') C... . A,'" in DATADIR.'/,' to continue.'$) C... READ (*,*) TEMPEX = .FALSE. ELSE C-- prepare constants for time conversion to OBT T0 = UDOUBLE(STARTOBT)*TIMECOMMON_SCCONVERSION CALL H_READ_JKEYWORD( 'TIMEREF', DAY70, 0, IER, 1 ) CALL TIME_1970( STARTARR,START70 ) TJ = START70 - DAY70 DO 80 J = 1,NT READ (IUN,REC=J+IZOFF,IOSTAT=IER,ERR=1000) TTEMPS(J),TEMPS(J) C-- convert times to elapsed OBT TTEMPS(J) = (TTEMPS(J)-TJ)*TIMECOMMON_SCALE TTEMPS(J) = TTEMPS(J) + T0 80 CONTINUE WRITE (*,*) 'INIT_CORRECT_PDS: Temperature time series loaded.' ENDIF CALL RESET_TABLE_DESC( HCOMMON_CURFILE ) CALL CLOSE_XAS_FILE( IUN ) * C-- Read the temperature dependence coeffs and PHA-PSA table C-- PHA_CH, PSA(PHW1) PSA(PHW2) PSA(PHW3) PSA(PHW4), skipping comment lines * c. FPHAPSA = XASTOP(1:TRUE_LENGTH(XASTOP))//'/calib/sax/pds/'//FCAL CALL BUILDPATH(FCAL,'CALIB',FPHAPSA) CALL Z_OPEN( IUN,FPHAPSA,'S','OLD',1 ) IF (VOSERROR(IVOS,ISYS)) THEN WRITE (*,*) CHAR(7)// . 'INIT_CORRECT_PDS: Error opening cal file '//FPHAPSA GOTO 999 ENDIF * C-- First row contains the 4x2 PSA chan. coeff. dependence with temperature * 100 READ (IUN,5,ERR=1000,IOSTAT=IER) BUFFER IF (BUFFER(1:1).EQ.'#') GOTO 100 READ (BUFFER,*,ERR=1000,IOSTAT=IER) . (TFAC(1,J), TFAC(2,J), J=1,4) * C-- Second row contains the reference temperature * 110 READ (IUN,5,ERR=1000,IOSTAT=IER) BUFFER IF (BUFFER(1:1).EQ.'#') GOTO 110 READ (BUFFER,*,ERR=1000,IOSTAT=IER) TEMP0 * I = 1 10 READ (IUN,5,ERR=1000,END=500,IOSTAT=IER) BUFFER IF (BUFFER(1:1).EQ.'#') GOTO 10 READ (BUFFER,*,ERR=1000,END=500,IOSTAT=IER) PHACH(I,1),PHACH(I,2), . (PSACH(I,J), PSAFWHM(I,J), J=1,4) * C-- Exit if max number of points reached... shouldn't happen! * IF (I .EQ. NBINST) GOTO 500 I = I + 1 GOTO 10 * 500 CLOSE (IUN) WRITE (*,*) 'INIT_CORRECT_PDS: NaI PSA peak table loaded.' WRITE (*,*) 'INIT_CORRECT_PDS: ',I,' data read' * C-- Set to 1 the index of the TEMPS/TTEMPS arrays JT = 1 SYSCOMMON_ICONV = SAVED * RETURN * C-- Errors * 999 WRITE(*,*)' file error : VOS ',IVOS,' sys ',ISYS CALL Z_EXIT( 1 ) 1000 CONTINUE WRITE(*,*)' data error : IOSTAT = ',IER CALL Z_EXIT( 2 ) * END C C SUBROUTINE RESET_TABLE_DESC(NTAB) C--> this provisional routine resets the table descriptor C--> in a future it will be enclosed in close_xas_file C--> currently it needs to be called if a time profile is closed C--> and another xas file is opened later with less columns than C--> the number of logical columns in a time profile C INTEGER I,NTAB C INCLUDE 'hcommon.inc' C INCLUDE 'bincommon.inc' C DO 1 I=1,BINCOMMON_MAXFIELDS C BINCOMMON_OFFSET(NTAB,I)=-1 C BINCOMMON_BITPIX(NTAB,I)=0 C BINCOMMON_DIMENS(NTAB,I)=0 C1 CONTINUE C RETURN C END