!+CIFCADD
subroutine cifcad
    implicit none

    ! Description:
    !  Opens a CIF (appropriate for a given mission and instrument).
    !  Creates a new CIF called cif.tmp and copies all data from old CIF (above)
    !  to new. Then adds a new column CAL_ORIG to new CIF (default value
    !  changed to 'HEASARC')...if works OK copy new CIF to old one.


    ! passed parameters: none
    !
    ! user i/ps (prompted for):
    ! none
    !
    ! Called routines :
    !  subroutine FCECHO       : (FITSIO) write to STDOUT
    !  subroutine CGETLUN      : (CALLIB) get free FORTRAN logical unit no
    !  subroutine CFRELUN      : (CALLIB) free FORTRAN logical unit no
    !  subroutine WT_FERRMSG   : (CALLIB) dumps error messages if necessary
    !  subroutine WTINFO       : (CALLIB) dumps error messages if necessary
    !  subroutine FTOPEN       : (FITSIO) opens FITS file
    !  subroutine FTCLOS       : (FITSIO) closes FITS file
    !  subroutine FTMAHD       : (FITSIO) moves to 1st extension in FITS file
    !  subroutine RDCNFG       : (CALLIB) reads the caldb.config file for
    !                                     given mission/instrument

    ! compilation & linking :
    !  link with XPI, FITSIO & CALLIB
    !
    ! Origin: Written for the Calibration Database.
    !
    ! Authors/Modification History:
    !  Lorraine Breedon (1.0.0:97 Jun 7) original version
    !  Lorraine Breedon (1.1.0:98 Apr 23) removed crtcif routine due to
    !                                     problems with ftcopy not
    !                                     clobbering 1st extn data in
    !                                     cif.tmp
    !  MFC (1.2.0 2020 Apr 16) f90 version; lengthened message, context strings
    !
    character(7) version
    parameter (version = '1.2.0')


    !-
    ! Internals
    character(160) calfexp
    character(400) message
    character(200) context
    character(20) mission, instru, alias, tform, origval
    character(30) sjunk
    character(6) subname
    character(8) ttype
    parameter (subname = 'cifcad')
    logical copen, oopen
    character(160) junkdir, cif, ciftmp, caldbpth
    character(30) errstr, warnstr
    integer fcstln, errstat, hdutype, ijunk, nax2val
    integer blcksz, j, caldblen, origcol
    integer ierr, chatter, ounit, cunit, i
    logical simple, extend
    integer bitpix, naxis, naxes(2), pcount, gcount

    ! initialise and set up defaults
    ierr = 0
    ounit = 0
    cunit = 0
    errstat = 0
    copen = .false.
    oopen = .false.
    calfexp = ' '

    message = '** CIFCADD ' // version
    call fcecho(message)
    errstr = '** CIFCADD ' // version // ' ERROR: '
    warnstr = '** CIFCADD ' // version // ' WARNING: '

    ! Get the parameters from the par file
    call gparms2(mission, instru, alias, calfexp, chatter, errstat)



    ! If there's an error getting parameters then return
    if (errstat .ne. 0) return

    ! see if the user has set the environment variable specified in the
    ! calfexp arguement
    call ctrlog(calfexp, fcstln(calfexp), caldbpth, caldblen)
    if (caldblen .eq. 0) then
        context = 'Environment variable not set'
        message = '**CIFCADD ' // version // ' ERROR : ' // context
        call fcecho(message)
        message = 'The environment variable or logical "'&
                // calfexp(:fcstln(calfexp)) // '"'
        call fcecho(message)
        message = 'must be set to point at the top of the Caldb'
        call fcecho(message)
        message = 'see the Caldb Users Guide for details'
        call fcecho(message)
        errstat = 2
        return
    endif

    ! get and read the caldb.config file to get path to CIF


    ! NOTE : caldb_info .... the instru argument
    ! MUST be the 'instrument alias' rather then the 'instrument'
    if ((calfexp(1:5).eq.'caldb').or.(calfexp(1:5).eq.'CALDB')) then

        call caldb_info(chatter, 'INST', mission, alias, errstat)
        if (errstat.ne.0) then
            message = 'CALDB not defined/available'
            call fcecho(message)
            message = 'task requires CALDB to be both defined ' // &
                    '& available in order to run'
            call wt_ferrmsg(errstat, message)
            goto 1000
        endif
        errstat = 0
        call rdcnfg(mission, alias, .false., calfexp, junkdir, errstat)

        if (errstat .ne. 0) return
    endif

    call cgetlun(cunit)
    call cgetlun(ounit)
    cif = calfexp




    ! See whether we have the CIF open. If not, then open it, and make
    ! a "back-up" copy (which is actually the guys we'll be working in)
    ! ------------------------------------------------------------

    ! ........ Open the old calibration index file and move to the first extension.
    call ftopen(cunit, cif(:fcstln(cif)), 1, blcksz, errstat)
    if (errstat .eq. 0) then
        copen = .true.
    else
        context = 'Cannot open the CIF'
        call wtferr(subname, version, errstat, context)
        context = 'offending file: ' // cif
        call wtinfo(chatter, 1, 1, context)
        ierr = 1
        goto 999
    endif
    call ftmahd(cunit, 2, hdutype, errstat)
    If (errstat .ne. 0) then
        context = 'Cannot move within the CIF'
        call wtferr(subname, version, errstat, context)
        context = 'offending file: ' // cif
        call wtinfo(chatter, 1, 1, context)
        ierr = 1
        goto 999
    endif



    ! .........For safety, create a new cif called 'cif.tmp' which will contain
    !          all the entries -- old and new.
    call wtinfo(chatter, 10, 1, 'Making back-up copy of CIF')
    j = index(cif, 'caldb.indx')
    ciftmp = cif(:j - 1) // 'cif.tmp   '
    simple = .true.
    blcksz = 0
    bitpix = 8
    naxis = 0
    naxes(1) = 0
    naxes(2) = 0
    pcount = 0
    gcount = 0
    extend = .true.

    call ftinit(ounit, ciftmp, blcksz, errstat)
    if (errstat .eq. 0) oopen = .true.
    if (errstat .eq. 105) then
        context = 'Please remove the file cif.tmp'
        goto 999
    endif

    call ftphpr(ounit, simple, bitpix, naxis, naxes, &
            pcount, gcount, extend, errstat)
    call ftpdef(ounit, bitpix, naxis, naxes, pcount, &
            gcount, errstat)


    ! ......... Copy all the data from the old cif to the new cif
    call ftcrhd(ounit, errstat)
    if (errstat .ne. 0) then
        context = 'Cannot create new FITS header' // &
                ' in back-up copy'
        call wtferr(subname, version, errstat, context)
        context = 'offending file: ' // ciftmp
        call wtinfo(chatter, 1, 1, context)
        ierr = 1
        goto 999
    endif

    call ftcopy(cunit, ounit, 0, errstat)

    if (errstat .ne. 0) then
        errstat = 0
        if (oopen) then
            call ftclos(ounit, errstat)
            oopen = .false.
            call delfil(ciftmp)
        endif
        context = 'Cannot copy data from CIF to temp file'
        goto 999
    endif
    call ftclos(cunit, errstat)
    if (errstat .ne. 0) copen = .false.


    ! now add extra column to backup copy ...the default value in this
    ! column will be `INDEF'...so will need to change this to `HEASARC'
    ttype = 'CAL_ORIG'
    tform = '20A'
    call fticol(ounit, 19, ttype, tform, errstat)
    if (errstat .ne. 0) then
        context = 'Cannot add extra column to: cif.tmp'
        call wtferr(subname, version, errstat, context)
        call wtinfo(chatter, 1, 1, context)
        oopen = .true.
        ierr = 1
        goto 999
    endif
    ! now move to 1st ext of backup copy

    call ftmahd(ounit, 2, ijunk, errstat)
    if(errstat.ne.0)then
        context = ' moving to 1st extension'
        call wtferr(subname, version, errstat, context)
        call wtinfo(chatter, 1, 1, context)
        oopen = .true.
        ierr = 1
        goto 999

    endif
    ! Find out how many rows the CIF contains
    call ftgkyj(ounit, 'NAXIS2', nax2val, sjunk, errstat)
    if(nax2val.eq.0)then
        ierr = 1
        goto 999
    endif

    ! ..replace `INDEF' value with `HEASARC' in the CAL_ORIG column

    origval = 'HEASARC'

    do 100 i = 1, nax2val
        ! Get the column number of the column to be read
        call ftgcno(ounit, .true., 'CAL_ORIG', origcol, errstat)
        if(errstat.ne.0)then
            context = ' getting CAL_ORIG column number '
            call wtferr(subname, version, errstat, context)
            call wtinfo(chatter, 1, 1, context)
            oopen = .true.
            ierr = 1
            goto 999
        endif

        call ftpcls(ounit, origcol, i, 1, 1, origval, errstat)
        if (errstat .ne. 0) then
            context = ' changing CAL_ORIG default value to HEASARC  '
            call wtferr(subname, version, errstat, context)
            call wtinfo(chatter, 1, 1, context)
            oopen = .true.
            ierr = 1
            goto 999
        endif

    100    continue
    ! close the new calibration index file
    call ftclos(ounit, errstat)
    if (errstat .ne. 0) then
        context = 'Cannot close index file: cif.tmp'
        call wtferr(subname, version, errstat, context)
        call wtinfo(chatter, 1, 1, context)
        oopen = .true.
        ierr = 1
        goto 999
    else
        call cfrelun(ounit)
        oopen = .false.
    endif


    ! Move the new cal index file onto the old one
    call mvfile(ciftmp, cif)

    ! Close the old calibration index file

    call ftclos(cunit, errstat)
    if (errstat .ne. 0) then
        context = 'Cannot close index file: caldb.indx'
        call wtferr(subname, version, errstat, context)
        copen = .true.
        ierr = 1
        goto 999
    else
        call cfrelun(cunit)
        copen = .false.
    endif

    999    if(ierr.ne.0) then
        context = 'Unable to continue ' // &
                ' -- attempting to shut down & clean up'
        call wtinfo(chatter, 1, 1, context)



        !	close the new calibration index file
        if (oopen) then
            call ftclos(ounit, errstat)
            if (errstat .ne. 0) then
                context = 'Cannot close index file: cif.tmp'
                call wtferr(subname, version, errstat, context)
                errstat = 0
            endif
            call cfrelun(ounit)
        endif

        !	Close the old calibration index file
        if (copen) then
            call ftclos(cunit, errstat)
            if (errstat .ne. 0) then
                context = 'Cannot close index file: caldb.indx'
                call wtferr(subname, version, errstat, context)
                errstat = 0
            endif
            call cfrelun(cunit)
        endif
    endif

    message = ' '
    call fcecho(message)
    message = '** CIFCADD ' // version // ' finished **'
    call fcecho(message)
    return
    1000    continue
end

!-----------------------------------------------------------------------

!+GPARMS2
subroutine gparms2(mission, instru, alias, calfexp, chatter, &
        status)

    implicit none
    character*(*) mission, instru, alias, calfexp
    integer status, chatter


    ! Description:
    !  Gets the parameters for CIFCADD from the parameter
    !  file.

    !
    ! passed parameters:
    !  CALFEXP     :    value of environment variable
    !  STATUS      :    error flg (0=OK)
    !  CHATTER     :    chattiness flag for o/p (5 low,10 normal,15 high)
    !
    ! user i/ps (prompted for):
    !  MISSION        :   the name of the mission
    !  INSTRU         :   the name of the instrument
    !  ALIAS          :   the name of the instrument alias
    !
    ! Called routines :
    !  subroutine UGLGST       : (XPI) gets parameter values from mudcif.par
    !  subroutine FCECHO       : (FITSIO) write to standard o/p
    !
    ! compilation & linking :
    !  link with XPI and FITSIO
    !
    ! Origin: Written for the Calibration Database.
    !
    ! Authors/Modification History:
    !  Lorraine Breedon (1.0.0:97 Jun 06) original version
    character(7) version
    parameter (version = '1.0.0')

    !-
    ! Internals

    character(50) contxt
    character(80) message
    integer errstat

    ! initialise
    ! Set Status flg to 'no problem!'
    status = 0
    errstat = 0



    ! Get mission parameter
    call uclgst('mission', mission, errstat)
    ! If there's an error getting mission, return
    if(errstat.ne.0)then
        contxt = 'cant get mission parameter'
        message = '**UCLGST ' // version // ' ERROR : ' // contxt
        call fcecho(message)
        status = 1
        return
    endif

    ! Get instrument parameter
    call uclgst('instrument', instru, errstat)
    ! If there's an error getting instrument, return
    if(errstat.ne.0)then
        contxt = 'cant get instrument parameter'
        message = '**UCLGST ' // version // ' ERROR : ' // contxt
        call fcecho(message)
        status = 1
        return
    endif

    ! Get instrument alias parameter
    call uclgst('instru_alias', alias, errstat)
    ! If there's an error getting instru_alias, return
    if(errstat.ne.0)then
        contxt = 'cant get instru_alias parameter'
        message = '**UCLGST ' // version // ' ERROR : ' // contxt
        call fcecho(message)
        status = 1
        return
    endif


    ! Get calfexp parameter
    call uclgst('calfexp', calfexp, errstat)
    ! If there's an error getting calfexp, return
    if(errstat.ne.0) then
        contxt = 'cant get calfexp parameter'
        message = '**UCLGST ' // version // ' ERROR : ' // contxt
        call fcecho(message)
        status = 1
        return
    endif

    ! Get the chatter parameter
    call uclgsi('chatter', chatter, errstat)
    if(errstat.ne.0)then
        contxt = 'cant get chatter parameter'
        message = '**UCLGST ' // version // ' ERROR : ' // contxt
        call fcecho(message)
        chatter = 9
        message = ' setting chatter=9'
        call fcecho(message)
        status = 0
    endif

    return
end
!-----------------------end of GPARMS2 subroutine----------------------