        SUBROUTINE VCALDO (
*
*  inputs
*
     :                  ROOT, OROOT, FLEN, OBSID,
     :                  NDK, NPA, NHV, NSN, NGN, NCV, NDT, NDKAP, NAREA,
     :                  PADET, HVDET, GNDET, CVDET, DTDET,
     :                  DKAPER, SNAPER, DKAP, DKDET, DKNAME, AREAAP,
     :                  DKHV, HVHV, DTHV, GNGAIN, CVGAIN,
     :                  DKTYPE, PATYPE, HVTYPE, DTDISC,
     :                  DKBASE, PABASE, HVBASE, SNBSPT, SNBSEX, GNBASE,
     :                  CVBASE, DTBASE, AREA,
     :                  DKCOFF, PACOFF, HVCOFF, SNCOFF, GNCOFF, CVCOFF,
     :                  DTCOFF,
     :                  DKTMP0, PATMP0, HVTMP0, SNTMP0, GNTMP0, CVTMP0,
     :                  DTTMP0,
     :                  DKEP0, PAEP0, HVEP0, SNEP0, GNEP0, CVEP0,
*
*  outputs
*
     :                  STATUS)
*
*  Module Number:
*
*  Module Name: CALHSP
*
*  Keyphrase:
*  ----------
*  main routine to perform RSDP (pipeline) calibration corrections
*
*  Description:
*  ------------
*
*  FORTRAN Name: VCALDO.FOR
*
*  Keywords of Accessed Files and Tables:
*  --------------------------------------
*
*  Name                         I/O     Description / Comments
*
*  Subroutines Called:
*  -------------------
*  CDBS:
*       VPPGHD, VMJD, VPPCOR
*  SDAS:
*       UUFACC, UIMOPN, UIMCLO, UIMGID, UUSLEN, UDMGET, UDMFRE, UUSLEN,
*       UIMOPC, UMSPUT, UUCTOD
*  OTHERS:
*       None
*
*  History:
*  --------
*  Version      Date        Author          Description
*     1       08-01-88     J.-C. Hsu        Design and coding
*     2       01-11-89     J.-C. Hsu        no need for time bias
*     3       08-11-89     J.-C. Hsu        new temperature dependent dead time
*     4       06-18-91     J.-C. Hsu        new packet time format (MJD)
*-------------------------------------------------------------------------------
*
*== input:
*                                       --input and output file root names
        CHARACTER*(*)           ROOT, OROOT,
*                                       --aperture names and dark aperture names
*                                       --in the dark aperture translation table
     :                          DKAP(1), DKNAME(1),
*                                       --aperture names in the aperture area
*                                       --table
     :                          AREAAP(1),
*                                       --aperture names in each calibration table
     :                          DKAPER(1), SNAPER(1),
*                                       --data types of each calibration table
     :                          DKTYPE(1), PATYPE(1), HVTYPE(1)
*                                       --detector ID in each calibration table
*                                       --(PA = pre-amp, HV = high voltage
*                                       --factor, CV = CVC offset, DT = dead
*                                       --time, DM = dummy, DK = dark signal,
*                                       --GN = gain factor, SN = relative
*                                       --sensitivity)
        INTEGER                 PADET(1), HVDET(1), GNDET(1),
     :                          CVDET(1), DTDET(1), DKDET(1),
*                                       --number of rows in dark aperture
*                                       --translation table
     :                          NDKAP,
*                                       --number of rows in aperture area table
     :                          NAREA,
*                                       --number of data entries in each
*                                       --calibration table
     :                          NDK, NHV, NPA, NSN, NGN, NCV, NDT,
*                                       --length of the input file root name
     :                          FLEN
*                                       --high voltage settings in each
*                                       --calibration table
        REAL                    DKHV(1), HVHV(1), DTHV(1),
*                                       --gain settings in each calibration table
     :                          GNGAIN(1), CVGAIN(1),
*                                       --discriminator threshold settings in
*                                       --the dead time calibration table
     :                          DTDISC(1),
*                                       --aperture area in the aperture are table
     :                          AREA(1),
*                                       --base values of each calibration table
     :                          DKBASE(1), PABASE(1), HVBASE(1),
*                                       --relative sensitivity has two base
*                                       --values for each set of coefficients
     :                          SNBSPT(1), SNBSEX(1),
     :                          GNBASE(1), CVBASE(1),
     :                          DTBASE(1),
*                                       --polynominal coefficients of calibration
     :                          DKCOFF(16,1), PACOFF(16,1),
     :                          HVCOFF(16,1), SNCOFF(16,1),
     :                          GNCOFF(16,1), CVCOFF(16,1),
*                                       --deadtime temperature dependent coeff
     :                          DTCOFF(1),
*                                       --zero points of temperature in each
*                                       --calibration table
     :                          DKTMP0(1), PATMP0(1), HVTMP0(1),
     :                          SNTMP0(1), GNTMP0(1), CVTMP0(1),
     :                          DTTMP0(1)
*                                       --zero points of epoch in each
*                                       --calibration table
        DOUBLE PRECISION        DKEP0(1), PAEP0(1), HVEP0(1),
     :                          SNEP0(1), GNEP0(1), CVEP0(1)
*
*== local:
*                                       --DEA and detector temperatures
        REAL                    DEATMP, DETTMP,
*                                       --sample time
     :                          SMPTM,
*                                       --gain, high voltage, and PAD theshold
*                                       --settings
     :                          GAIN, HV, THRESH
*                                       --detector ID
        INTEGER                 DET,
*                                       --return status
     :                          STATUS,
*                                       --return status
     :                          STAT(30), STATOK,
*                                       --file pointer
     :                          INMID, SHPID, UDLID, MSKID,
*                                       --input file dynamic memory pointer
     :                          IP,
*                                       --input mask dynamic memory pointer
     :                          MP,
*                                       --input file data type
     :                          DTYPE,
*                                       --input file number of axis
     :                          NAXIS,
*                                       --input file dimensions
     :                          DIMEN(7),
*                                       --number of input files
     :                          NFILES,
*                                       --number of points in one section
     :                          CHUNK, NPS,
*                                       --length of the output file root name
     :                          OFLEN,
*                                       --loop indices
     :                          I, J,
     :                          IPE
        PARAMETER               (CHUNK = 100000)
*                                       --modified Julian days of start, stop,
*                                       --and mean epoches
        DOUBLE PRECISION        STRTJD, STOPJD, EPOCH
*                                       --point source flag
        CHARACTER*1             PTFLAG,
     :                          CHAR1
*                                       --calibration switches
        CHARACTER*8             DETCSW, DEADSW, CNTSW, PHCSW,
*                                       --data type
     :                          TYPE
*                                       --aperture name
        CHARACTER*10            APERT,
*                                       --observation ID
     :                          OBSID
*                                       --times of first and last packets
        CHARACTER*24            STRTTM, STOPTM
*                                       --input,output, data quality mask file
*                                       --names
        CHARACTER*128           INFILE, OFILE, INMASK, FNAME(2)
*                                       --error message context
        CHARACTER*130           CONTXT, TEXT
*                                       --existence flag of outtable
        LOGICAL                 EXIST
*==========================begin iraf77.inc (without INTEGER*2)=================
*     Include file for the iraf77 FORTRAN interface to the IRAF VOS
*     Get IRAF common into main program
*
      LOGICAL MEMB(1)
      INTEGER MEMI(1)
      INTEGER MEML(1)
      REAL MEMR(1)
      DOUBLE PRECISION MEMD(1)
      COMPLEX MEMX(1)
      EQUIVALENCE (MEMB, MEMI, MEML, MEMR, MEMD, MEMX)
      COMMON /MEM/ MEMD
*
*     File I/O access modes
*
      INTEGER   RDONLY
      PARAMETER (RDONLY = 1)
      INTEGER   RDWRIT
      PARAMETER (RDWRIT = 2)
      INTEGER   WRONLY
      PARAMETER (WRONLY = 3)
      INTEGER   APPEND
      PARAMETER (APPEND = 4)
      INTEGER   NEWFIL
      PARAMETER (NEWFIL = 5)
      INTEGER   TMPFIL
      PARAMETER (TMPFIL = 6)
      INTEGER   NEWCPY
      PARAMETER (NEWCPY = 7)
      INTEGER   NEWIMG
      PARAMETER (NEWIMG = 5)
*
*     codes for data types
*
      INTEGER   TYBOOL
      PARAMETER (TYBOOL = 1)
      INTEGER   TYCHAR
      PARAMETER (TYCHAR = 2)
      INTEGER   TYSHOR
      PARAMETER (TYSHOR = 3)
      INTEGER   TYINT
      PARAMETER (TYINT = 4)
      INTEGER   TYLONG
      PARAMETER (TYLONG = 5)
      INTEGER   TYREAL
      PARAMETER (TYREAL = 6)
      INTEGER   TYDOUB
      PARAMETER (TYDOUB = 7)
      INTEGER   TYCPLX
      PARAMETER (TYCPLX = 8)
      INTEGER   TYUSHT
      PARAMETER (TYUSHT = 11)
      INTEGER   TYUBYT
      PARAMETER (TYUBYT = 12)
*
*     TYTEXT is a special code for the iraf77 interface; it is not in the VOS
*
      INTEGER TYTEXT
      PARAMETER (TYTEXT = 13)
*========================end iraf77.inc=========================================
*=========================begin hsp.inc=========================================
*                                       --status return code
        INTEGER         OK, ERRNUM(20)
*                                       --message destination and priority
        INTEGER         DEST, PRIO
        DATA OK /0/
        DATA ERRNUM /701, 702, 703, 704, 705, 706, 707, 708, 709, 710,
     :               711, 712, 713, 714, 715, 716, 717, 718, 719, 720/
        DATA DEST, PRIO /1, 0/
*=========================end hsp.inc===========================================
*
*  initialize pointers to zero
*
        IP = 0
        MP = 0
        INMID = 0
        MSKID = 0
        SHPID = 0
        UDLID = 0
*
*  determine output root name's length
*
        CALL UUSLEN (OROOT,      OFLEN)
*
*  open input SHP and UDL files
*
        FNAME(1) = ROOT(1:FLEN) // '.shh'
        FNAME(2) = ROOT(1:FLEN) // '.ulh'
        CALL UIMOPN (FNAME(1), RDONLY,      SHPID, STAT(1))
        CALL UIMOPN (FNAME(2), RDONLY,      UDLID, STAT(2))
*
        DO 10 I = 1, 2
            IF (STAT(I) .NE. OK) THEN
                STATUS = ERRNUM(1)
                CONTXT = 'cannot open file ' // FNAME(I)
                GO TO 999
            END IF
   10   CONTINUE
*
        NFILES = 0
*
*  process all four files
*
        DO 60 I = 0, 3
            WRITE (CHAR1, '(I1)') I
*
*  assume input file extensions are .d0h through .d3h
*
            INFILE = ROOT(1:FLEN) // '.d' // CHAR1 // 'h'
*
*  check existence of input file, skip if not existed
*
            CALL UUFACC (INFILE,   EXIST, STATOK)
            IF (.NOT. EXIST) GO TO 60
*
            NFILES = NFILES + 1
*
*  open the science file and its mask
*
            INMASK = ROOT(1:FLEN) // '.q' // CHAR1 // 'h'
            OFILE = OROOT(1:OFLEN) // '.c' // CHAR1 // 'h'
*
            CALL UIMOPN (INFILE, RDONLY,      INMID, STAT(1))
            CALL UIMOPN (INMASK, RDONLY,      MSKID, STAT(2))
            IF (STAT(1) .NE. OK .OR. STAT(2) .NE. OK) THEN
                STATUS = ERRNUM(1)
                CONTXT = 'cannot open input file or its mask '
                GO TO 999
            END IF
*
*  read first file's size and allocate dynamic memory.
*  files with the same root name should have same dimensions.
*  since area scan is not to be processed, we only deal with 1-D data.
*
            IF (NFILES .EQ. 1) THEN
                CALL UIMGID (INMID,   DTYPE, NAXIS, DIMEN, STAT(1))
                NPS = CHUNK
                IF (DIMEN(1) .LT. CHUNK) NPS = DIMEN(1)
                CALL UDMGET (NPS, TYREAL,   IP, STAT(2))
                CALL UDMGET (NPS, TYREAL,   MP, STAT(3))
*
                DO 20 J = 1, 3
                    IF (STAT(J) .NE. OK) THEN
                        STATUS = ERRNUM(1)
                        CONTXT = 'cannot get file size info or '
     :                            // 'fail to allocate dynamic memory'
                        GO TO 999
                    END IF
   20           CONTINUE
            END IF
*
*  read keywords from file header and from SHP and UDL file headers
*
            CALL VPPGHD (INFILE, INMID, SHPID, UDLID, OBSID,    PTFLAG, 
     :                   DETCSW, DEADSW, CNTSW, PHCSW, TYPE, SMPTM, DET, 
     :                   APERT, STRTTM, STOPTM, DEATMP, DETTMP,
     :                   GAIN, HV, THRESH, STATUS)
            IF (STATUS .NE. OK) THEN
                CONTXT = 'cannot read keywords of file ' // INFILE
                GO TO 999
            END IF
*
*  decide whether to do the calibration based from the calibration switches
*  if calibration switch(es) is OMIT, no .c* files are generated
*
            IF ((TYPE(1:7) .EQ. 'DIGITAL'  .AND.  DEADSW .NE. 'PERFORM'
     :          .AND.   CNTSW .NE. 'PERFORM')   .OR.
     :          (TYPE(1:6) .EQ. 'ANALOG'  .AND.  PHCSW .NE. 'PERFORM'))
     :		THEN
                CONTXT = OBSID // 'calibration switches are turned off ' 
                CALL UMSPUT (CONTXT, DEST, PRIO,        STATOK)
                GO TO 40
            END IF
*
*  calculate average epoch by taking the mean of start and stop time packets
*
            EPOCH = 0.D0
            CALL VMJD (STRTTM,     STRTJD, STAT(1))
            CALL VMJD (STOPTM,     STOPJD, STAT(2))
*
*  the following is for the new MJD packet times
*  added in June 1991
*
            IF (STAT(1) .NE. OK .AND. STAT(2) .NE. OK) THEN
                CALL UUCTOD (STRTTM, 1,     IPE, STRTJD, STAT(1))
                CALL UUCTOD (STOPTM, 1,     IPE, STOPJD, STAT(2))
            END IF
*
            IF (STAT(1) .NE. OK .OR. STAT(2) .NE. OK) THEN
                STATUS = ERRNUM(1)
                CONTXT = 'cannot calculate Julian date from '
     :                          // STRTTM // ' or ' // STOPTM
                GO TO 999
            END IF
*
            EPOCH = (STRTJD + STOPJD) / 2.D0
*
*  calibration correction
*
            CALL VPPCOR (
     :                  OBSID, INMID, OFILE, MSKID, IP, MP,
     :                  DIMEN(1), CHUNK,
     :                  PTFLAG, DEADSW, CNTSW, PHCSW, TYPE, 
     :                  DET, APERT, GAIN, HV, THRESH,
     :                  DETTMP, DEATMP, EPOCH, SMPTM,
     :                  NDK, NPA, NHV, NSN, NGN, NCV, NDT, NDKAP, NAREA,
     :                  PADET, HVDET, GNDET, CVDET, DTDET,
     :                  DKAPER, SNAPER, DKAP, DKDET, DKNAME, AREAAP,
     :                  DKHV, HVHV, DTHV, GNGAIN, CVGAIN,
     :                  DKTYPE, PATYPE, HVTYPE, DTDISC,
     :                  DKBASE, PABASE, HVBASE, SNBSPT, SNBSEX, GNBASE,
     :                  CVBASE, DTBASE, AREA,
     :                  DKCOFF, PACOFF, HVCOFF, SNCOFF, GNCOFF, CVCOFF,
     :                  DTCOFF,
     :                  DKTMP0, PATMP0, HVTMP0, SNTMP0, GNTMP0, CVTMP0,
     :                  DTTMP0,
     :                  DKEP0, PAEP0, HVEP0, SNEP0, GNEP0, CVEP0,
     :                  STATUS)
*
            IF (STATUS .NE. OK) THEN
                CONTXT = 'cannot perform the pipeline correction'
                GO TO 999
            END IF
*
*  close the input file/mask
*
   40       CALL UIMCLO (INMID,         STAT(1))
            CALL UIMCLO (MSKID,         STAT(2))
*
            DO 50 J = 1, 2
                IF (STAT(J) .NE. OK) THEN
                    STATUS = ERRNUM(1)
                    CONTXT = 'cannot close input file/mask'
                    GO TO 999
                END IF
   50       CONTINUE
   60   CONTINUE
*
*  check if there is any file existing
*
        IF (NFILES .EQ. 0) THEN
            STATUS = ERRNUM(1)
            CONTXT = 'no existing input science file'
            GO TO 999
        END IF
*
*  free dynamic memory and close SHP and UDL
*
        CALL UDMFRE (IP, TYREAL,        STAT(1))
        CALL UDMFRE (MP, TYREAL,        STAT(2))
        CALL UIMCLO (SHPID,             STAT(3))
        CALL UIMCLO (UDLID,             STAT(4))
*
        DO 70 I = 1, 4
            IF (STAT(I) .NE. OK) THEN
                STATUS = ERRNUM(1)
                CONTXT = 'cannot free dynamic memory or close SHP/UDL'
                GO TO 999
            END IF
   70   CONTINUE
*
        STATUS = OK
        GO TO 1000
*
*  write error message
*
  999   TEXT = OBSID // '  VCALDO: ' // CONTXT
        CALL UMSPUT (TEXT, DEST, PRIO,        STATOK)
*
*  close any unresolved dynamic memory or files
*
        IF (INMID .NE. 0)    CALL UIMCLO (INMID,         STATOK)
        IF (MSKID .NE. 0)    CALL UIMCLO (MSKID,         STATOK)
        IF (SHPID .NE. 0)    CALL UIMCLO (SHPID,         STATOK)
        IF (UDLID .NE. 0)    CALL UIMCLO (UDLID,         STATOK)
        IF (IP .NE. 0)       CALL UDMFRE (IP, TYREAL,    STATOK)
        IF (MP .NE. 0)       CALL UDMFRE (MP, TYREAL,    STATOK)
*
 1000   RETURN
        END
