!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   EVB-QMDFF - RPMD molecular dynamics and rate constant calculations on
!               black-box generated potential energy surfaces
!
!   Copyright (c) 2021 by Julien Steffen (steffen@pctc.uni-kiel.de)
!                         Stefan Grimme (grimme@thch.uni-bonn.de) (QMDFF code)
!
!   Permission is hereby granted, free of charge, to any person obtaining a
!   copy of this software and associated documentation files (the "Software"),
!   to deal in the Software without restriction, including without limitation
!   the rights to use, copy, modify, merge, publish, distribute, sublicense,
!   and/or sell copies of the Software, and to permit persons to whom the
!   Software is furnished to do so, subject to the following conditions:
!
!   The above copyright notice and this permission notice shall be included in
!   all copies or substantial portions of the Software.
!
!   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
!   IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
!   FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
!   THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
!   LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
!   FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
!   DEALINGS IN THE SOFTWARE.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!
!     subroutine int2grad: converts an array of internal gradients to cartesian
!     coordinates
!
!     part of EVB
!

subroutine int2grad(xyz5,internal,g_q,g_x)
use evb_mod
implicit none

real(kind=8)::xyz5(3,natoms),internal(nat6)
real(kind=8)::B_mat(nat6,3*natoms)
real(kind=8)::Bt(3*natoms,nat6)
real(kind=8)::u(3*natoms,3*natoms)
real(kind=8)::Bu(3*natoms,3*natoms)
real(kind=8)::G(3*natoms,3*natoms),V(3*natoms,3*natoms)
real(kind=8)::xyza(3*natoms),eigen(3*natoms)
real(kind=8)::Vt(3*natoms,3*natoms)
real(kind=8),dimension(3*natoms,3*natoms)::Vlam,V1
real(kind=8)::G_min(3*natoms,3*natoms)
real(kind=8)::G_minB(3*natoms,nat6)
real(kind=8)::G_minBu(nat6,3*natoms)
real(kind=8)::g_q(nat6),g_x(3*natoms),g_q1(3*natoms)
real(kind=8)::ug_x(3*natoms),Bug_x(3*natoms),g_test(3*natoms)
real(kind=8)::coord,hi,lo,shift
real(kind=8)::dist,ang,dihed,oop
real(kind=8)::q_test(nat6)
! only for test reasons
real(kind=8)::g2_x(3,natoms),gu_q(nat6),gd_q(nat6)
real(kind=8)::method2
integer::n

integer::i,j,k,m,l,c,o
integer::nat
nat=natoms
n=nat
do i=1,nat
   do j=1,3
      xyza((i-1)*3+j)=xyz5(j,i)
   end do
end do
!
!  first, build the Wilson B matrix
!
call calc_wilson(xyz5,internal,B_mat)
if (B_mat(1,1) .ne. B_mat(1,1)) then
write(*,*) "NAN in Wikson!"
end if
!
!  Transpose the Wilson Matrix B (--> Bt)
!
Bt=0
do i=1,nat6
   do j=1,3*nat
      Bt(j,i)=B_mat(i,j)
   end do
end do

!
!   calculate the cartesian gradient
!

g_x=matmul(Bt,g_q)

return
end subroutine int2grad


      SUBROUTINE DECODE2
C*****THIS SUBROUTINE READS A CODEV DATA FILE
C
C**  COMMON BLOCK CODEV DECLARATIONS
      CHARACTER*4 DIM,APERT(225)
      INTEGER*4 ICCY(0:225),ITHC(0:225),IGLC(0:225),IWTW1,IWTW2,IWTW3
      INTEGER*4 IWTW4,IWTW5,IWTW6,IWTW7,ICCX(30),KC(66),IAC(66),IBC(66)
      INTEGER*4 ICC(66),IDC(66),IXDC(100),IYDC(100),IADC(100),IBDC(100)
      INTEGER*4 ICDC(100),ICCF(66)
      REAL*4 ORDER(66),WLF1,WLF2,WLF3,WLF4,WLF5,WLF6,WLF7
      REAL*4 F(225),AL(66),AM(66),AN(66)
      REAL*8 RFND1(20),RFND2(20),RFND3(20),RFND4(20),RFND5(20)
C** COMMON BLOCK BOTH DECLARATIONS
      CHARACTER*4 SOLVE(40)
      CHARACTER*13 GLASS(0:225)
      CHARACTER*64 TITLE
      INTEGER*4 I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,M,ISTOP,IREF,ISURF
      INTEGER*4 NAPERT(225),NDECE(100),NSOLVE(40),NUMA,MESSAGE(20)
      REAL*4 DIF(66)
      REAL*8 ADE(100),BDE(100),CDE(100),XDE(100),YDE(100),CURVEY(0:225)
      REAL*8 THICKNS(0:225),RK(66),A(66),B(66),C(66),D(66),SOLVF1(40)
      REAL*8 F1(225)
      LOGICAL AFO,IC(66),CUF(66)
C** COMMON BLOCK CAONLY DECLARATIONS
      CHARACTER*3 SURFMES(20),SOLVE1(40),SOLVE2(40)
      CHARACTER*4 TYPE(66)
      CHARACTER*13 CATALOG(20),MATRL(20),GL(0:225)
      CHARACTER*24 SUBMES4(20)
      INTEGER*4 NTYPE(66),NRETUT(100),NRETUF(100),IPKCV1(200)
      INTEGER*4 IPKAD1(200),IPKAD2(200),IPKAE1(200),IPKAE2(200)
      INTEGER*4 IPKAF1(200),IPKAF2(200),IPKAG1(200),IPKAG2(200)
      INTEGER*4 IPKA1(200),IPKA2(200),IPKB1(200),IPKB2(200),IPKG1(200)
      INTEGER*4 IPKG2(200),IPKX1(200),IPKX2(200),IPKY1(200),IPKY2(200)
      INTEGER*4 IPKGL1(200),IPKGL2(200),IPKTH1(200),IPKTH2(200)
      INTEGER*4 IPKCC1(200),IPKCC2(200),ICCA(200),ICVA(200),ITHA(200)
      INTEGER*4 IGLA(200),IAEA(200),IAFA(200),IAGA(200),IADA(200)
      INTEGER*4 IXA(200),IYA(200),IAA(200),IBA(200),IGA(200),J1,J2,J3
      INTEGER*4 J4,J5,J6,J7,J8,J9,JE,JF,JG,JD,JX,JY,JA,JB,JM
      INTEGER*4 INDICE(225),ICIR(225),IRECT(225),IELIP(225),ICOCYF(20)
      INTEGER*4 ICOCYT(20),ICOCXF(20),ICOCXT(20),TILT(66),RTILT(66)
      INTEGER*4 RDECE(100),MESNUM(20),IPKCV2(200)
      REAL*4 WL1(20),WL2(20),WL3(20),WL4(20),WL5(20),WL6(20),WL7(20)
      REAL*4 TWL1(20),TWL2(20),TWL3(20),TWL4(20),TWL5(20)
      REAL*4 CATWL1(20),CATWL2(20),CATWL3(20),CATWL4(20),CATWL5(20)
      REAL*4 CATWL6(20),CATWL7(20),W1(20),W2(20),W3(20),W4(20),W5(20)
      REAL*4 IND1(20),IND2(20),IND3(20),IND4(20),IND5(20),TIND1(20)
      REAL*4 TIND2(20),TIND3(20),TIND4(20),TIND5(20)
      REAL*8 UMARG,YMARG,UCHIEF,UMARG,CUX(30),RADE(100),RBDE(100)
      REAL*8 RCDE(100),RXDE(100),RYDE(100)
      LOGICAL VIGNET,TEL,RETURN(100),ZMFLAG
C** LOCAL DECLARATIONS
      CHARACTER*110 LINE
      CHARACTER*4 FLAG1,FLAG2
      REAL*4 WAVE1,WAVE2
C
      COMMON /CODEV/DIM,APERT,ICCY,ITHC,IGLC,IWTW1,IWTW2,IWTW3,IWTW4,
     *        IWTW5,IWTW6,ILWTW7,ICCX,KC,IAC,IBC,ICC,IDC,ORDER,IXDC,
     *        IYDC,IADC,IBDC,ICDC,ICCF,WLF1,WLF2,WLF3,WLF4,WLF5,WLF6,
     *        WLF7,RFND1,RFND2,RFND3,RFND4,RFND5,F,AL,AM,AN
      COMMON /BOTH/I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,GLASS,MESSAGE,M,
     *        ISTOP,IREF,ISURF,AFO,NAPERT,NDECE,F1,DIF,ADE,BDE,CDE,XDE,
     *        YDE,CURVEY,THICKNS,RK,A,B,C,D,IC,CUF,NSOLVE,SOLVF1,SOLVE,
     *        TITLE,NUMA
      COMMON /CAONLY/UMARG,YMARG,UCHIEF,YCHIEF,TYPE,NTYPE,NRETUT,
     *        NRETUF,CATWL1,CATWL2,CATWL3,CATWL4,CATWL5,CATWL6,CATWL7,
     *        CUX,VIGNET,TEL,RETURN,MATRL,SOLVE1,SOLVE2,ZMFLAG,SURFMES,
     *        CATALOG,WL1,WL2,WL3,WL4,WL5,WL6,WL7,IND1,IND2,IND3,IN4,
     *        IND5,TWL1,TWL2,TWL3,TWL4,TWL5,TIND1,TIND2,TIND3,TIND4,
     *        TIND5,GL,IPKCV1,IPKCV2,IPKAD1,IPKAD2,IPKAE1,IPKAE2,
     *        IPKAF1,IPKAF2,IPKAG1,IPKAG2,IPKA1,IPKA2,IPKB1,IPKB2,
     *        IPKG1,IPKG2,IPKX1,IPKX2,IPKY1,IPKY2,IPKTH1,IPKTH2,IPKCC1,
     *        IPKCC2,ICCA,ICVA,ITHA,IGLA,IAEA,IAFA,IAGA,IADA,IXA,IYA,
     *        IAA,IBA,IGA,J1,J2,J3,J4,J5,J6,J7,J8,J9,JE,JF,JG,JD,JX,JY,
     *        JA,JB,JM,INDICE,ICIR,IRECT,IELIP,ICOCYF,ICOCYT,ICOCXF,
     *        ICOCXT,TILT,RTILT,W1,W2,W3,W4,W5,RDECE,RADE,RBDE,RCDE,
     *        RXDE,RYDE,MESNUM,SUBMES4
C
C*******************************************************************************
C*****FORMAT STATEMENTS
  2   FORMAT(A110)
  4   FORMAT(5X,F14.8,I4,6X,F15.6,1X,I4,8X,A13,1X,I4,22X,A1,A7)
  6   FORMAT(16X,2F12.6,3X,F10.6,3X,F10.6,3X,F10.6,4X,A4)
  8   FORMAT(19X,I4,9X,I4,9X,I4,9X,I4,9X,I4)
 10   FORMAT(16X,I6)
 12   FORMAT(29X,A1)
 14   FORMAT(21X,F10.2,3X,F10.2,3X,F10.2,3X,F10.2,3X,F10.2,3X,F10.2,
     *   3X,F10.2)
 15   FORMAT(26X,I4,9X,I4,9X,I4,9X,I4,9X,I4,9X,I4,9X,I4)
 16   FORMAT(7X,A3,I3,6X,F12.5)
 18   FORMAT(22X,F8.2,5X,F8.2,5X,F8.2,5X,F8.2,5X,F8.2,5X,F8.2,5X,F8.2)
 19   FORMAT(7X,A13,14X,F9.6,4X,F9.6,4X,F9.6,4X,F9.6,4X,F9.6)
 20   FORMAT(7X,A13,1X,F9.6,4X,F9.6,4X,F9.6,4X,F9.6,4X,F9.6)
 22   FORMAT(3X,F13.8,4X,I3,7X,F10.6,14X,F12.8,6X,I3)
 24   FORMAT(5X,F14.6,I4,8X,F13.6,2X,I3,6X,F13.6,4X,I3,2X,F13.6,3X,I3)
 26   FORMAT(12X,F10.6,4X,F10.6,4X,F10.6,4X,F10.6,4X,F10.6)
 28   FORMAT(5X,F14.8,I4)
 30   FORMAT(26X,I4)
 31   FORMAT(48X,F11.6)
 32   FORMAT(3X,F11.6,F11.6,11X,F11.6)
 34   FORMAT(5X,A46)
 36   FORMAT(7X,A3,I3,1X,A3,4X,F9.6)
 38   FORMAT(41X,F10.2)
C*******************************************************************************
C*****INITIALIZE
C
      I=0
      I1=1
      I2=1
      I3=1
      I4=1
      I5=1
      I6=1
      I7=1
      M=1
      DO 100,J=1,20
        CATWL1(J)=0.0
        CATWL2(J)=0.0
        CATWL3(J)=0.0
        CATWL4(J)=0.0
        CATWL5(J)=0.0
        CATWL6(J)=0.0
        CATWL7(J)=0.0
        WL1(J)=0.0
        WL2(J)=0.0
        WL3(J)=0.0
        WL4(J)=0.0
        WL5(J)=0.0
        WL6(J)=0.0
        WL7(J)=0.0
100     CONTINUE
      DO 105,J=1,66
        IC(J)=.FALSE.
105   CONTINUE
      DO 110,J=1,100
        RETURN(J)=.FALSE.
110   CONTINUE
      ZMFLAG=.FALSE.
      VIGNET=.FALSE.
      IREF=0.0
      DIM=' '
      WLF1=0.0
      WLF2=0.0
      WLF3=0.0
      WLF4=0.0
      WLF5=0.0
      WLF6=0.0
      WLF7=0.0
      IWTW1=0
      IWTW2=0
      IWTW3=0
      IWTW4=0
      IWTW5=0
      IWTW6=0
      IWTW7=0
C******************************************************************************
C*****TITLE
180   READ(6,2)LINE
      READ(6,2)LINE
      READ(6,34)TITLE
C*******************************************************************************
C*****SURFACE DATA
C
200   READ(6,2)LINE
      IF (LINE(6:9) .NE. 'SURF') GOTO 200
205   READ(6,2)LINE
      IF (LINE(2:4) .NE. 'OBJ') GOTO 205
208   IF (LINE(9:12) .EQ. 'DECE') GOTO 210
      IF (LINE(9:12) .EQ. 'RETU') GOTO 215
      IF (LINE(9:12) .EQ. ' ') GOTO 223
      IF ((LINE(6:7) .EQ. '**') .OR. (LINE(6:7) .EQ. '--')) GOTO  225
C*****SIMPLE SURFACE DATA - 1 DATA LINE
      READ(LINE,4)CURVEY(I),ICCY(I),THICKNS(I),ITHC(I),GLASS(I),IGLC(I),
     *  FLAG1,FLAG2
      IF (FLAG1 .EQ. 'S') ISTOP=I
      IF (FLAG2 .NE. ' ') THEN /*SPECIAL SURFACE - 1 OR 2 DATA LINES
         TYPE(I4)=FLAG2
         NTYPE(I4)=I
         IF (TYPE(I4) .EQ. 'CYL') THEN
           READ(6,28)CUX(I4),ICCX(I4)
           I4=I4+1
           GOTO 220
          END IF
C******SURFACES NOT HANDLED
       IF ((TYPE(I4) .EQ. 'SPL') .OR. (TYPE(I4) .EQ. 'CON') .OR.
     *    (TYPE(I4) .EQ. 'THG') .OR. (TYPE(I4) .EQ. 'HOE') .OR.
     *    (TYPE(I4) .EQ. 'AAS')) GOTO 217
         IF (TYPE(I4) .EQ. 'CYL') THEN
           READ(6,28)CUX(I4),ICCX(I4)
           I4=I4+1
           GOTO 220
         END IF
         READ(6,22)RK(I4),KC(I4),FLAG3,FLAG4,ICCF(I4)
         READ(6,24)A(I4),IAC(I4),B(I4),IBC(I4),C(I4),ICC(I4),D(I4),
     *     IDC(I4)
         IF (FLAG4 .GT. 0) CUF(I)=.TRUE.
         IF (FLAG3 .EQ. -1.0) IC(I4)=.TRUE.
         IF (TYPE(I4) .EQ. 'GRT') READ(6,26)ORDER(I4),DIF(I4),AL(I4),
     *     AM(I4),AN(I4)
         IF (TYPE(I4) .EQ. 'YTO') READ(6,28)CUX(I4),ICCX(I4)
         I4=I4+1
        ELSE
          GOTO 220
      END IF
      GOTO 220
C*****DECENTER DATA - 2 DATA LINES
210   READ(LINE,6)XDE(I2),YDE(I2),ADE(I2),BDE(I2),CDE(I2),FLAG1
      IF (FLAG1 .EQ. 'RETU') RETURN(I2)=.TRUE.
      NDECE(I2)=I
      READ(6,8)IXDC(I2),IYDC(I2),IADC(I2),IBDC(I2),ICDC(I2)
      I2=I2+1
      GOTO 223
C*****RETURN ONLY DATA - 1 DATA LINE
215   READ(LINE,10)ITEMP
      NRETUT(I3)=ITEMP
      NRETUF(I3)=I
      I3=I3+1
      GOTO 223
C*****SURFACES NOT HANDLED
217   IF (TYPE(I4) .EQ. 'SPL') I=3
      IF (TYPE(I4) .EQ. 'CON') I=1
      IF (TYPE(I4) .EQ. 'THG') I=4
      IF (TYPE(I4) .EQ. 'HOE') I=4
      IF (TYPE(I4) .EQ. 'AAS') I=4
      MESSAGE(M)=4
      SURFMES(M)=TYPE(I4)
      M=M+1
      DO 218,K=1,I
        READ(6,2)LINE  /* SKIP SPECIAL SURFACE DATA LINES
218   CONTINUE
      GOTO 223
220   I=I+1
223   READ(6,2)LINE
      GOTO 208
225   ISURF=I-1 /*TOTAL NUMBER OF SURFACES
C*******************************************************************************
C*****SPECIFICATION DATA
228   READ(6,2)LINE
      IF (LINE(6:9) .NE. 'SPEC') GOTO 228
      READ(6,2)LINE  /*SKIP 3 BLANK LINES
      READ(6,2)LINE
      READ(6,2)LINE
230   READ(6,2)LINE
      IF (LINE(8:10) .EQ. 'DIM') THEN
       READ(LINE,12)DIM
       ELSE IF (LINE(8:10) .EQ. 'WL') THEN
        READ(LINE,14)WLF1,WLF2,WLF3,WLF4,WLF5,WLF6,WLF7
         IF (WLF1 .GT. 0.0) J=1 /*COUNT WAVE LENGTHS
         IF (WLF2 .GT. 0.0) J=2
         IF (WLF3 .GT. 0.0) J=3
         IF (WLF4 .GT. 0.0) J=4
         IF (WLF5 .GT. 0.0) J=5
         IF (WLF6 .GT. 0.0) J=6
         IF (WLF7 .GT. 0.0) THEN
          WLF1=WLF2   /* IF MORE THAN 7 WAVE LENGTHS
          WLF2=WLF3   /* THROW FIRST AWAY
          WLF3=WLF4
          WLF4=WLF5
          WLF5=WLF6
          J=7
         END IF
        ELSE IF (LINE(8:10) .EQ. 'WTW') THEN
         READ(LINE,15)IWTW1,IWTW2,IWTW3,IWTW4,IWTW5
         IF (IWTW7 .GT. 0) THEN
           IWTW1=IWTW2
           IWTW2=IWTW3
           IWTW3=IWTW4
           IWTW4=IWTW5
           IWTW5=IWTW6
         END IF
         ELSE IF (LINE(8:10) .EQ. 'REF') THEN
          READ(LINE,30)IREF
          ELSE IF (LINE(8:10) .EQ. 'AFO') THEN
           AFO=.TRUE.
           ELSE IF ((LINE(8:10) .EQ. 'VUY') .OR.
     *       (LINE(8:10) .EQ. 'VUX')) THEN
            IF (VIGNET) GOTO 230
            MESSAGE(M)=1
            M=M+1
            VIGNET=.TRUE.
           ELSE IF (LINE(8:10) .EQ. 'VUX') THEN
            MESSAGE(M)=1
            M=M+1
            ELSE IF (LINE(8:10) .EQ. 'TEL') THEN
             MESSAGE(M)=2
             M=M+1
             ELSE IF (LINE(8:10) .EQ. ' ') THEN
              GOTO 300
       END IF
      GOTO 230
C*******************************************************************************
C*****DETERMINE NEXT CATEGORY
300   READ(6,2)LINE
      IF (LINE(6:13) .EQ. 'APERTURE') THEN
        GOTO 305
       ELSE IF (LINE(6:12) .EQ. 'PRIVATE') THEN
         GOTO 320
        ELSE IF (LINE(6:15) .EQ. 'REFRACTIVE') THEN
          GOTO 340
         ELSE IF (LINE(6:10) .EQ. 'SOLVE') THEN
           GOTO 350
          ELSE IF (LINE(6:9) .EQ. 'ZOOM') THEN
            GOTO 400
           ELSE IF (LINE(5:7) .EQ. 'ANA') THEN
             GOTO 500
      END IF
      GOTO 300
C*******************************************************************************
C*****APERTURE DATA
305   READ(6,2)LINE /*SKIP A LINE
310   READ(6,2)LINE
      IF (LINE(8:10) .EQ. ' ') GOTO 300
      READ(LINE,16)APERT(I1),NAPERT(I1),F1(I1)
      IF ((APERT(I1) .EQ. 'ADX ') .OR. (APERT(I1) .EQ. 'ADY ') .OR.
     *    (APERT(I1) .EQ. 'AGR ') .OR. (APERT(I1) .EQ. 'CIG ') .OR.
     *    (APERT(I1) .EQ. 'REG ') .OR. (APERT(I1) .EQ. 'ELG ') .OR.
     *    (APERT(I1) .EQ. 'ORA ')) THEN
       SUBMES4(M)=LINE(8:31)
       MESSAGE(M)=7
       M=M+1
       IF (APERT(I1) .EQ. 'ORA ') READ(6,2)LINE /*SKIP A LINE
      ELSE
        I1=I1+1
      END IF
      GOTO 310
C*******************************************************************************
C*****PRIVATE CATALOG
320   READ(6,2)LINE /*SKIP 2 BLANK LINES
      READ(6,2)LINE
      READ(6,2)LINE
325   READ(LINE,18)CATWL1(I5),CATWL2(I5),CATWL3(I5),CATWL4(I5),
     *  CATWL5(I5),CATWL6(I5),CATWL7(I5)
        IF (CATWL7(I5) .GT. 0.0) THEN
          CATWL1(I5)=CATWL2(I5)
          CATWL2(I5)=CATWL3(I5)
          CATWL3(I5)=CATWL4(I5)
          CATWL4(I5)=CATWL5(I5)
          CATWL5(I5)=CATWL6(I5)
          READ(6,19)CATALOG(I5),RFND1(I5),RFND2(I5),RFND3(I5),RFND4(I5),
     *    RFND5(I5)
        ELSE
330       READ(6,20)CATALOG(I5),RFND1(I5),RFND2(I5),RFND3(I5),RFND4(I5),
     *    RFND5(I5)
        END IF
      READ(6,2)LINE
      IF (LINE(8:17) .EQ. ' ') THEN
        GOTO 300
        ELSE IF (LINE(8:9) .NE.'WL') THEN
          I5=I5+1
          CATWL1(I5)=CATWL1(I5-1)
          CATWL2(I5)=CATWL2(I5-1)
          CATWL3(I5)=CATWL3(I5-1)
          CATWL4(I5)=CATWL4(I5-1)
          CATWL5(I5)=CATWL5(I5-1)
          GOTO 330
        ELSE
          I5=I5+1
          GOTO 325
       END IF
C*******************************************************************************
C*****REFRACTIVE INDICES
340   READ(6,2)LINE /*SKIP A LINE
      READ(6,18)WL1(I7),WL2(I7),WL3(I7),WL4(I7),WL5(I7),
     *  WL6(I7),WL7(I7)
        IF (WL7(I7) .GT. 0.0) THEN
          WL1(I7)=WL2(I7)
          WL2(I7)=WL3(I7)
          WL3(I7)=WL4(I7)
          WL4(I7)=WL5(I7)
          WL5(I7)=WL6(I7)
          READ(6,19)MATRL(I5),IND1(I7),IND2(I7),IND3(I7),IND4(I7),
     *    IND5(I7)
        ELSE
345       READ(6,20)MATRL(I5),IND1(I7),IND2(I7),IND3(I7),IND4(I7),
     *    IND5(I7)
        END IF
      IF (MATRL(I5) .EQ. ' ') THEN
        I7=I7-1 /*IGNORE CLASS CODE WITHOUT INDEX.
        GOTO 300
       END IF
      IND1(I7)=ABS(IND1(I7))
      IND2(I7)=ABS(IND2(I7))
      IND3(I7)=ABS(IND3(I7))
      IND4(I7)=ABS(IND4(I7))
      IND5(I7)=ABS(IND5(I7))
      READ(6,2)LINE
      IF (LINE(8:11) .EQ. ' ') GOTO 300
      I7=I7+1
      WL1(I7)=WL1(I7-1)
      WL2(I7)=WL2(I7-1)
      WL3(I7)=WL3(I7-1)
      WL4(I7)=WL4(I7-1)
      WL5(I7)=WL5(I7-1)
      GOTO 345
C*******************************************************************************
C*****SOLVES
350   READ(6,2)LINE
355   READ(6,2)LINE
      IF (LINE(8:10) .EQ. ' ') GOTO 300
      READ(LINE,36)SOLVE1(I6),NSOLVE(I6),SOLVE2(I6),SOLVF1(I6)
C*****SOLVES NOT TRANSLATED
      IF ((SOLVE2(I6) .EQ. 'ET ') .OR. (SOLVE2(I6) .EQ. 'OAL')) GOTO 355
      IF ((SOLVE1(I6) .EQ. 'RED') .OR. (SOLVE1(I6) .EQ. 'SUR')) GOTO 355
      I6=I6+1
      GOTO 355
C*******************************************************************************
C*****ZOOM
400   MESSAGE(M)=3
      M=M+1
      ZMFLAG=.TRUE.
      GOTO 300
C*******************************************************************************
C*****ANALYSIS
500   READ(6,2)LINE
      READ(6,2)LINE
      IF (LINE(10:12) .NE. 'FIR') GOTO 300 /*WRONG ANALYSIS SECTION
      IF (ZMFLAG) THEN
        I=(J+1)/2
        IF (I .EQ. 1) THEN
          WAVE1=WLF1
        ELSE IF (I .EQ. 2) THEN
          WAVE1=WLF2
        ELSE IF (I .EQ. 3) THEN
          WAVE1=WLF3
        END IF
510     READ(6,2)LINE
        IF (LINE(25:39) .NE. 'PARAXIAL VALUES') GOTO 510
        READ(LINE,38)WAVE2
        IF (WAVE1 .NE. WAVE2) GOTO 510
        DO 515,K=1,6
          READ(6,2)LINE
515     CONTINUE
        IF (LINE(2:3) .NE. 'EP') GOTO 510
        IF (THICKNS(0) .EQ. 0D0) READ(6,2)LINE
        READ(LINE,31)UCHIEF
        READ(6,32)YMARG,UMARG,YCHIEF
      ELSE
520     READ(6,2)LINE
        IF (LINE(2:3) .NE. 'EP') GOTO 520
        IF (THICKNS(0) .EQ. 0D0) READ(6,2)LINE
        READ(LINE,31)UCHIEF
        READ(6,32)YMARG,UMARG,YCHIEF
      END IF
C*******************************************************************************
C*****TEST SECTION
C      PRINT*, 'ISURF:',ISURF
C      PRINT*, 'TITLE; ',TITLE
C      DO 600,J=0,ISURF
C        PRINT*, 'SURFACE: ',J,'CURVATURE: ',CURVEY(J),'THICKNESS: ',
C     *    THICKNS(J)
C        PRINT*, 'THC: ',ITHC(J),'GLASS: ',GLASS(J),'GLC: ',IGLC(J)
C      PRINT*, 'CCY:',ICCY(J)
C600   CONTINUE
C      PRINT*, 'STOP SURF: ',ISTOP
C      DO 610,J=1,I4
C      PRINT*, 'SPECIAL TYPE: ',TYPE(J),'SURFACE: ',NTYPE(J)
C      PRINT*, 'K: ',RK(J),' C:',KC(J),' IC:',IC(J),' CUF:',CUF(J),
C     *   'CCF:',ICCF(J)
C      PRINT*, 'A:',A(J),' AC:',IAC(J),' B:',B(J),' BC:',IBC(J),' C:',
C     *   C(J),' CC:',ICC(J),' D:',D(J),' DC:',IDC(J)
C      IF (TYPE(J) .EQ. 'GRT') PRINT*, 'GRT: N:',ORDER(J),' DIF:',
C     *  DIF(J),' L:',AL(J),' M:',AM(J),' N:',AN(J)
C      IF (TYPE(J) .EQ. 'YTO') PRINT*, 'YTO: CUX:',CUX(J),' CC:',ICCX(J)
C610   CONTINUE
C      PRINT*, 'DECENTERS:'
C      DO 620,J=1,I2
C      PRINT*, 'SURFACE:',NDECE(J),' XDE:',XDE(J),' YDE:',YDE(J)
C      PRINT*, 'ADE:',ADE(J),' BDE:',BDE(J),' CDE:',CDE(J),'RETURN:',
C     *   RETURN(J)
C      PRINT*, 'XDC:',IXDC(J),' YDC:',IYDC(J),' ADC:',IADC(J),' BDC:',
C     *   IBDC(J),' CDC:',ICDC(J)
C620   CONTINUE
C      PRINT*, 'RETURN ONLY:'
C      DO 630,J=1,I3
C      PRINT*, 'SURFACE:',NRETUF(J),' RETURN TO:',NRETUT(J)
C630   CONTINUE
C      DO 640,J=1,I1
C      PRINT*, 'APERTURE:',APERT(J),' SURFACE:',NAPERT(J),' SIZE:',F1(J)
C640   CONTINUE
C      PRINT*, 'MATERIALS AND REFRACTIVE INDICES:'
C      DO 650,J=1,I5
C      PRINT*, 'MATERIAL:',MATRL(J)
C      PRINT*, 'WAVE LENGTHS:',CATWL1(J),CATWL2(J),CATWL3(J),CATWL4(J),
C     *  CATWL5(J)
C      PRINT*, 'INDICES:',RFND1(J),RFND2(J),RFND3(J),RFND4(J),RFND5(J)
C650   CONTINUE
C      PRINT*, 'YMARG:',YMARG,' UMARG:',UMARG,' YCHIEF:',YCHIEF,
C     *   ' UCHIEF:',UCHIEF
C*****END TEST SECTION
      RETURN
      END
      SUBROUTINE CONVERT2
C*****THIS SUBROUTINE TRANSLATES CODEV COMMANDS TO ACCOSV COMMANDS
C
C** COMMON BLOCK CODEV DECLARATIONS
      CHARACTER*4 DIM,APERT(225)
      INTEGER*4 ICCY(0:225),ITHC(0:225),IGLC(0:225),IWTW1,IWTW2,IWTW3
      INTEGER*4 IWTW4,IWTW5,IWTW6,IWTW7,ICCX(30),KC(66),IAC(66),IBC(66)
      INTEGER*4 ICC(66),IDC(66),IXDC(100),IYDC(100),IADC(100),IBDC(100)
      INTEGER*4 ICDC(100),ICCF(66)
      REAL*4 ORDER(66),WLF1,WLF2,WLF3,WLF4,WLF5,WLF6,WLF7
      REAL*4 F(225),AL(66),AM(66),AN(66)
      REAL*8 RFND1(20),RFND2(20),RFND3(20),RFND4(20),RFND5(20)
C** COMMON BLOCK BOTH DECLARATIONS
      CHARACTER*4 SOLVE(40)
      CHARACTER*13 GLASS(0:225)
      CHARACTER*64 TITLE
      INTEGER*4 I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,M,ISTOP,IREF,ISURF
      INTEGER*4 NAPERT(225),NDECE(100),NSOLVE(40),NUMA,MESSAGE(20)
      REAL*4 DIF(66)
      REAL*8 ADE(100),BDE(100),CDE(100),XDE(100),YDE(100),CURVEY(0:225)
      REAL*8 THICKNS(0:225),RK(66),A(66),B(66),C(66),D(66),SOLVF1(40)
      REAL*8 F1(225)
      LOGICAL AFO,IC(66),CUF(66)
C** COMMON BLOCK ACCOSV DECLARATIONS
      CHARACTER*6 UNITS
      INTEGER*4 IORDER(66),IWT1,IWT2,IWT3,IWT4,IWT5
      REAL*4 WVW1,WVW2,WVW3,WVW4,WVW5,WT1,WT2,WT3,WT4,WT5,THETA(66)
      REAL*4 RN1
      REAL*8 N1(20),N2(20),N3(20),N4(20),N5(20),F2(225)
C** COMMON BLOCK CAONLY DECLARATIONS
      CHARACTER*3 SURFMES(20),SOLVE1(40),SOLVE2(40)
      CHARACTER*4 TYPE(66)
      CHARACTER*13 CATALOG(20),MATRL(20),GL(0:225)
      CHARACTER*24 SUBMES4(20)
      INTEGER*4 NTYPE(66),NRETUT(100),NRETUF(100),IPKCV1(200)
      INTEGER*4 IPKAD1(200),IPKAD2(200),IPKAE1(200),IPKAE2(200)
      INTEGER*4 IPKAF1(200),IPKAF2(200),IPKAG1(200),IPKAG2(200)
      INTEGER*4 IPKA1(200),IPKA2(200),IPKB1(200),IPKB2(200),IPKG1(200)
      INTEGER*4 IPKG2(200),IPKX1(200),IPKX2(200),IPKY1(200),IPKY2(200)
      INTEGER*4 IPKGL1(200),IPKGL2(200),IPKTH1(200),IPKTH2(200)
      INTEGER*4 IPKCC1(200),IPKCC2(200),ICCA(200),ICVA(200),ITHA(200)
      INTEGER*4 IGLA(200),IAEA(200),IAFA(200),IAGA(200),IADA(200)
      INTEGER*4 IXA(200),IYA(200),IAA(200),IBA(200),IGA(200),J1,J2,J3
      INTEGER*4 J4,J5,J6,J7,J8,J9,JE,JF,JG,JD,JX,JY,JA,JB,JM
      INTEGER*4 INDICE(225),ICIR(225),IRECT(225),IELIP(225),ICOCYF(20)
      INTEGER*4 ICOCYT(20),ICOCXF(20),ICOCXT(20),TILT(66),RTILT(66)
      INTEGER*4 RDECE(100),MESNUM(20),IPKCV2(200)
      REAL*4 WL1(20),WL2(20),WL3(20),WL4(20),WL5(20),WL6(20),WL7(20)
      REAL*4 TWL1(20),TWL2(20),TWL3(20),TWL4(20),TWL5(20)
      REAL*4 CATWL1(20),CATWL2(20),CATWL3(20),CATWL4(20),CATWL5(20)
      REAL*4 CATWL6(20),CATWL7(20),W1(20),W2(20),W3(20),W4(20),W5(20)
      REAL*4 IND1(20),IND2(20),IND3(20),IND4(20),IND5(20),TIND1(20)
      REAL*4 TIND2(20),TIND3(20),TIND4(20),TIND5(20)
      REAL*8 UMARG,YMARG,UCHIEF,UMARG,CUX(30),RADE(100),RBDE(100)
      REAL*8 RCDE(100),RXDE(100),RYDE(100)
      LOGICAL VIGNET,TEL,RETURN(100),ZMFLAG
C** LOCAL DECLARATIONS
      CHARACTER*4 FLAG1,FLAG2
      CHARACTER*15 GLSAVE
      INTEGER*4 IPK(200),Q,DUMMY(100)
      REAL*4 FLAG3,FLAG4,THSAVE,ANGLE
      LOGICAL DFIRST(225)
C
      COMMON /CODEV/DIM,APERT,ICCY,ITHC,IGLC,IWTW1,IWTW2,IWTW3,IWTW4,
     *        IWTW5,IWTW6,ILWTW7,ICCX,KC,IAC,IBC,ICC,IDC,ORDER,IXDC,
     *        IYDC,IADC,IBDC,ICDC,ICCF,WLF1,WLF2,WLF3,WLF4,WLF5,WLF6,
     *        WLF7,RFND1,RFND2,RFND3,RFND4,RFND5,F,AL,AM,AN
      COMMON /BOTH/I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,GLASS,MESSAGE,M,
     *        ISTOP,IREF,ISURF,AFO,NAPERT,NDECE,F1,DIF,ADE,BDE,CDE,XDE,
     *        YDE,CURVEY,THICKNS,RK,A,B,C,D,IC,CUF,NSOLVE,SOLVF1,SOLVE,
     *        TITLE,NUMA
      COMMON /ACCOSV/IORDER,WVW1,WVW2,WVW3,WVW4,WVW5,WT1,WT2,WT3,WT4,
     *        WT5,IWT1,IWT2,IWT3,IWT4,IWT5,THETA,F2,RN1,UNITS,N1,
     *        N2,N3,N4,N5
      COMMON /CAONLY/UMARG,YMARG,UCHIEF,YCHIEF,TYPE,NTYPE,NRETUT,
     *        NRETUF,CATWL1,CATWL2,CATWL3,CATWL4,CATWL5,CATWL6,CATWL7,
     *        CUX,VIGNET,TEL,RETURN,MATRL,SOLVE1,SOLVE2,ZMFLAG,SURFMES,
     *        CATALOG,WL1,WL2,WL3,WL4,WL5,WL6,WL7,IND1,IND2,IND3,IN4,
     *        IND5,TWL1,TWL2,TWL3,TWL4,TWL5,TIND1,TIND2,TIND3,TIND4,
     *        TIND5,GL,IPKCV1,IPKCV2,IPKAD1,IPKAD2,IPKAE1,IPKAE2,
     *        IPKAF1,IPKAF2,IPKAG1,IPKAG2,IPKA1,IPKA2,IPKB1,IPKB2,
     *        IPKG1,IPKG2,IPKX1,IPKX2,IPKY1,IPKY2,IPKTH1,IPKTH2,IPKCC1,
     *        IPKCC2,ICCA,ICVA,ITHA,IGLA,IAEA,IAFA,IAGA,IADA,IXA,IYA,
     *        IAA,IBA,IGA,J1,J2,J3,J4,J5,J6,J7,J8,J9,JE,JF,JG,JD,JX,JY,
     *        JA,JB,JM,INDICE,ICIR,IRECT,IELIP,ICOCYF,ICOCYT,ICOCXF,
     *        ICOCXT,TILT,RTILT,W1,W2,W3,W4,W5,RDECE,RADE,RBDE,RCDE,
     *        RXDE,RYDE,MESNUM,SUBMES4
C
C******************************************************************************
C*****INITIALIZE
      DUMMY(1)=0
      J1=0
      J2=0
      J3=0
      J4=0
      J5=0
      J6=0
      J7=0
      J8=0
      J9=0
      JD=0
      JE=0
      JF=0
      JG=0
      JX=0
      JY=0
      JA=0
      JB=0
      JG=0
      WVW1=0.0
      WVW2=0.0
      WVW3=0.0
      WVW4=0.0
      WVW5=0.0
      IWT1=0
      IWT2=0
      IWT3=0
      IWT4=0
      IWT5=0
      DO 100,J=1,20
        W1(J)=0.0
        W2(J)=0.0
        W3(J)=0.0
        W4(J)=0.0
        W5(J)=0.0
        N1(J)=0.0
        N2(J)=0.0
        N3(J)=0.0
        N4(J)=0.0
        N5(J)=0.0
100   CONTINUE
      DO 110,J=1,225
        ICIR(J)=-1
        IRECT(J)=-1
        IELIP(J)=-1
        DFIRST(J)=.FALSE.
110   CONTINUE
      DO 120,J=1,66
        TILT(J)=-1
        RTILT(J)=-1
120   CONTINUE
C******************************************************************************
C*****MAIN PROGRAM BEGINS
C*****SHIFT SURFACES: 1 INTO 0, 2 INTO 1, 3 INTO 2, ETC., IF THICKNESS ON
C***** SURFACE 0 IS 0.
      IF (THICKNS(0) .EQ. 0.0) THEN
        CALL ZEROSHIFT(ISURF,CURVEY,THICKNS,GLASS,NTYPE,ISTOP,NDECE,
     *  NRETUT,NRETUF,NAPERT,NSOLVE,ICCY,ITHC,IGLC,I1,I2,I3,I4,I6)
        M=M+1
        MESSAGE(M)=6
      END IF
C******************************************************************************
C*****DECENTERED SURFACES WITH RETURNS
      DO 150,J=1,I2-1
        IF (RETURN(J)) THEN
          J8=J8+1
          THSAVE=THICKNS(NDECE(J))
          THICKNS(NDECE(J))=0.0
          GLSAVE=GLASS(NDECE(J))
          GLASS(NDECE(J))='        '
          CALL SHIFT(NDECE(J)+1,ISURF,CURVEY,THICKNS,GLASS,NTYPE,ISTOP,
     *      NDECE,NRETUT,NRETUF,NAPERT,NSOLVE,ICCY,ITHC,IGLC,RDECE,
     *      I1,I2,I3,I4,I6,J8)
          RDECE(J8)=NDECE(J)+1
          RADE(J8)=ADE(J)
          RBDE(J8)=BDE(J)
          RCDE(J8)=CDE(J)
          RXDE(J8)=XDE(J)
          RYDE(J8)=YDE(J)
          THICKNS(NDECE(J)+1)=THSAVE
          GLASS(NDECE(J))=GLSAVE
          IF ((ITHC(NDECE(J)) .NE. 0) .AND.
     *        (ITHC(NDECE(J)) .NE. 100)) THEN
            ITHC(NDECE(J)+1)=ITHC(NDECE(J))
            ITHC(NDECE(J))=0
          END IF
        END IF
        DO 140,K=1,I4-1
          IF ((TYPE(K) .EQ. 'GRT') .AND. (NTYPE(K) .EQ. NDECE(J)))
     *      DFIRST(NDECE(J))=.TRUE.
140     CONTINUE
150   CONTINUE
C******************************************************************************
C*****SPECIAL SURFACES
      DO 175,J=1,I4-1
        IF (TYPE(J) .EQ. 'GRT') THEN
          IORDER (J)=INT(ORDER(J))  /*CONVERT DIF TO MICRONS
          IF (DIM .EQ. 'I   ') DIF(J)=25400.0*DIF(J)
          IF (DIM .EQ. 'C   ') DIF(J)=10000.0*DIF(J)
          IF (DIM .EQ. 'M   ') DIF(J)=1000.0*DIF(J)
          Q=0
C***  CASE 1: L=+-1  M=0  N=0
          IF ((ABS(AL(J)) .EQ. 1.0) .AND. (AM(J) .EQ. 0.0) .AND.
     *      (AN(J) .EQ. 0.0)) THEN
            DIF(J)=DIF(J)
C***  CASE 2: L=0  M=+-1  N=0
          ELSE IF ((AL(J) .EQ. 0.0) .AND. (ABS(AM(J)) .EQ. 1.0) .AND.
     *      (AN(J) .EQ. 0.0)) THEN
            IF (DFIRST(NTYPE(J))) THEN  /* DFIRST SIGNALS A DECENTER & RETURN
C                                       /* WHICH TRANSLATES TO 2 SURFACES. THE
              DO 152,K=1,J8             /* GRT TRANSLATES TO 3 SURFACES BETWEEN
C*                                      /* THE DECENTER AND RETURN SURFACES
                IF (RDECE(K) .EQ. (NTYPE(J)+1)) Q=1
152           CONTINUE
              IF (Q .NE. 1)  /*MAKE ROOM FOR ONESHIFT IF RETURN DOESN'T EXIST
     *           CALL SHIFT(NTYPE(J)+1,ISURF,CURVEY,THICKNS,GLASS,
     *            NTYPE,ISTOP,NDECE,NRETUT,NRETUF,NAPERT,NSOLVE,
     *            ICCY,ITHC,IGLC,RDECE,I1,I2,I3,I4,I6,J8)
              CALL ONESHIFT(NTYPE(J),CURVEY,THICKNS,GLASS,
     *         ISTOP,NAPERT,NSOLVE,ICCY,ITHC,IGLC,I1,I4,I6)
C**** SHIFT DATA TO MAKE ROOM FOR 1ST GRATING SURFACE
              ELSE
              Q=0
            END IF
            DIF(J)=DIF(J)
            J9=J9+1
            TILT(J9)=NTYPE(J)
            THETA(J9)=-90.0
            THSAVE=THICKNS(NTYPE(J))
            CALL SHIFT(NTYPE(J),ISURF,CURVEY,THICKNS,GLASS,NTYPE,
     *       ISTOP,NDECE,NRETUT,NRETUF,NAPERT,NSOLVE,ICCY,ITHC,IGLC,
     *       RDECE,I1,I2,I3,I4,I6,J8)
C***  SHIFT DATA TO MAKE ROOM FOR 2ND GRATING SURFACE
            THICKNS(NTYPE(J))=0.0
            CALL SHIFT(NTYPE(J)+1,ISURF,CURVEY,THICKNS,GLASS,NTYPE,
     *       ISTOP,NDECE,NRETUT,NRETUF,NAPERT,NSOLVE,ICCY,ITHC,IGLC,
     *       RDECE,I1,I2,I3,I4,I6,J8)
            RTILT(J9)=NTYPE(J)+1
C***   SHIFT DATA TO MAKE ROOM FOR 3RD GRATING SURFACE
            IF (Q .EQ. 1) THEN
              CALL SHIFT(NTYPE(J)+2,ISURF,CURVEY,THICKNS,GLASS,NTYPE,
     *         ISTOP,NDECE,NRETUT,NRETUF,NAPERT,NSOLVE,ICCY,ITHC,IGLC,
     *         RDECE,I1,I2,I3,I4,I6,J8)     /* SHIFT DATA TO MAKE ROOM FOR
              THICKNS(NTYPE(J)+2)=THSAVE    /* DECENTER RETURN SURFACE IF IT
              IF ((ITHC(NTYPE(J)) .NE. 0) .AND.  /*EXISTS AND PUT THICKNESS HERE
     *            (ITHC(NTYPE(J)) .NE. 100)) THEN
                ITHC(NTYPE(J)+2)=ITHC(NTYPE(J))
                ITHC(NTYPE(J))=0  /*PICKUP UP STAYS WITH THICKNESS SURFACE
              END IF
              DO 155,K=1,J8
                IF (RDECE(K) .EQ. NTYPE(J)) RDECE(K)=RDECE(K)+2
155            CONTINUE
            ELSE
              THICKNS(NTYPE(J)+1)=THSAVE    /* THICKNESS GOES ON 2ND GRATING
              IF ((ITHC(NTYPE(J)) .NE. 0) .AND. /*SURFACE IF NOT DECENTER
     *            (ITHC(NTYPE(J)) .NE. 100)) THEN /*RETURN SURFACE.  PICKUP
                 ITHC(NTYPE(J)+1)=ITHC(NTYPE(J))  /*STAYS WITH THICKNESS
                 ITHC(NTYPE(J))=0                 /*SURFACE
              END IF
            END IF
C***  CASE 3: -1<L<1  -1<M<1  N=0
          ELSE IF (AN(J) .EQ. 0.0) THEN
            IF (DFIRST(NTYPE(J))) THEN  /* DFIRST SIGNALS A DECENTER & RETURN
C                                       /* WHICH TRANSLATES TO 2 SURFACES. THE
              DO 157,K=1,J8             /* GRT TRANSLATES TO 3 SURFACES BETWEEN
C*                                      /* THE DECENTER AND RETURN SURFACES
                IF (RDECE(K) .EQ. (NTYPE(J)+1)) Q=1
157           CONTINUE
              IF (Q .NE. 1)  /*MAKE ROOM FOR ONESHIFT IF RETURN DOESN'T EXIST
     *           CALL SHIFT(NTYPE(J)+1,ISURF,CURVEY,THICKNS,GLASS,
     *            NTYPE,ISTOP,NDECE,NRETUT,NRETUF,NAPERT,NSOLVE,
     *            ICCY,ITHC,IGLC,RDECE,I1,I2,I3,I4,I6,J8)
              CALL ONESHIFT(NTYPE(J),CURVEY,THICKNS,GLASS,
     *         ISTOP,NAPERT,NSOLVE,ICCY,ITHC,IGLC,I1,I4,I6)
C**** SHIFT DATA TO MAKE ROOM FOR 1ST GRATING SURFACE
              ELSE
              Q=0
            END IF
            DIF(J)=DIF(J)
            J9=J9+1
            TILT(J9)=NTYPE(J)
            THETA(J9)=ATAN(AM(J)/AL(J))
            THSAVE=THICKNS(NTYPE(J))
            CALL SHIFT(NTYPE(J),ISURF,CURVEY,THICKNS,GLASS,NTYPE,
     *       ISTOP,NDECE,NRETUT,NRETUF,NAPERT,NSOLVE,ICCY,ITHC,IGLC,
     *       RDECE,I1,I2,I3,I4,I6,J8)
C***  SHIFT DATA TO MAKE ROOM FOR 2ND GRATING SURFACE
            THICKNS(NTYPE(J))=0.0
            CALL SHIFT(NTYPE(J)+1,ISURF,CURVEY,THICKNS,GLASS,NTYPE,
     *       ISTOP,NDECE,NRETUT,NRETUF,NAPERT,NSOLVE,ICCY,ITHC,IGLC,
     *       RDECE,I1,I2,I3,I4,I6,J8)
            RTILT(J9)=NTYPE(J)+1
C***   SHIFT DATA TO MAKE ROOM FOR 3RD GRATING SURFACE
            IF (Q .EQ. 1) THEN
              CALL SHIFT(NTYPE(J)+2,ISURF,CURVEY,THICKNS,GLASS,NTYPE,
     *         ISTOP,NDECE,NRETUT,NRETUF,NAPERT,NSOLVE,ICCY,ITHC,IGLC,
     *         RDECE,I1,I2,I3,I4,I6,J8)     /* SHIFT DATA TO MAKE ROOM FOR
              THICKNS(NTYPE(J)+2)=THSAVE    /* DECENTER RETURN SURFACE IF IT
              IF ((ITHC(NTYPE(J)) .NE. 0) .AND.  /*EXISTS AND PUT THICKNESS HERE
     *            (ITHC(NTYPE(J)) .NE. 100)) THEN
                ITHC(NTYPE(J)+2)=ITHC(NTYPE(J))
                ITHC(NTYPE(J))=0  /*PICKUP UP STAYS WITH THICKNESS SURFACE
              END IF
              DO 160,K=1,J8
                IF (RDECE(K) .EQ. NTYPE(J)) RDECE(K)=RDECE(K)+2
160           CONTINUE
            ELSE
              THICKNS(NTYPE(J)+1)=THSAVE    /* THICKNESS GOES ON 2ND GRATING
              IF ((ITHC(NTYPE(J)) .NE. 0) .AND. /*SURFACE IF NOT DECENTER
     *            (ITHC(NTYPE(J)) .NE. 100)) THEN /*RETURN SURFACE.  PICKUP
                 ITHC(NTYPE(J)+1)=ITHC(NTYPE(J))  /*STAYS WITH THICKNESS
                 ITHC(NTYPE(J))=0                 /*SURFACE
              END IF
            END IF
C***  CASE 4: L=0  -1<M<1  -1<N<1
          ELSE IF ((AL(J) .EQ. 0.0) .AND. (ABS(AN(J)) .LT. 1.0)) THEN
            IF (DFIRST(NTYPE(J))) THEN  /* DFIRST SIGNALS A DECENTER & RETURN
C                                       /* WHICH TRANSLATES TO 2 SURFACES. THE
              DO 162,K=1,J8             /* GRT TRANSLATES TO 3 SURFACES BETWEEN
C*                                      /* THE DECENTER AND RETURN SURFACES
                IF (RDECE(K) .EQ. (NTYPE(J)+1)) Q=1
162           CONTINUE
              IF (Q .NE. 1)  /*MAKE ROOM FOR ONESHIFT IF RETURN DOESN'T EXIST
     *           CALL SHIFT(NTYPE(J)+1,ISURF,CURVEY,THICKNS,GLASS,
     *            NTYPE,ISTOP,NDECE,NRETUT,NRETUF,NAPERT,NSOLVE,
     *            ICCY,ITHC,IGLC,RDECE,I1,I2,I3,I4,I6,J8)
              CALL ONESHIFT(NTYPE(J),CURVEY,THICKNS,GLASS,
     *         ISTOP,NAPERT,NSOLVE,ICCY,ITHC,IGLC,I1,I4,I6)
C**** SHIFT DATA TO MAKE ROOM FOR 1ST GRATING SURFACE
              ELSE
              Q=0
            END IF
            ANGLE=ATAN(AM(J)/AN(J))
            DIF(J)=(DIF(J)/SIN(ANGLE))
            J9=J9+1
            TILT(J9)=NTYPE(J)
            THETA(J9)=-90.0
            THSAVE=THICKNS(NTYPE(J))
            CALL SHIFT(NTYPE(J),ISURF,CURVEY,THICKNS,GLASS,NTYPE,
     *       ISTOP,NDECE,NRETUT,NRETUF,NAPERT,NSOLVE,ICCY,ITHC,IGLC,
     *       RDECE,I1,I2,I3,I4,I6,J8)
C***  SHIFT DATA TO MAKE ROOM FOR 2ND GRATING SURFACE
            THICKNS(NTYPE(J))=0.0
            CALL SHIFT(NTYPE(J)+1,ISURF,CURVEY,THICKNS,GLASS,NTYPE,
     *       ISTOP,NDECE,NRETUT,NRETUF,NAPERT,NSOLVE,ICCY,ITHC,IGLC,
     *       RDECE,I1,I2,I3,I4,I6,J8)
            RTILT(J9)=NTYPE(J)+1
C***   SHIFT DATA TO MAKE ROOM FOR 3RD GRATING SURFACE
            IF (Q .EQ. 1) THEN
              CALL SHIFT(NTYPE(J)+2,ISURF,CURVEY,THICKNS,GLASS,NTYPE,
     *         ISTOP,NDECE,NRETUT,NRETUF,NAPERT,NSOLVE,ICCY,ITHC,IGLC,
     *         RDECE,I1,I2,I3,I4,I6,J8)     /* SHIFT DATA TO MAKE ROOM FOR
              THICKNS(NTYPE(J)+2)=THSAVE    /* DECENTER RETURN SURFACE IF IT
              IF ((ITHC(NTYPE(J)) .NE. 0) .AND.  /*EXISTS AND PUT THICKNESS HERE
     *            (ITHC(NTYPE(J)) .NE. 100)) THEN
                ITHC(NTYPE(J)+2)=ITHC(NTYPE(J))
                ITHC(NTYPE(J))=0  /*PICKUP UP STAYS WITH THICKNESS SURFACE
              END IF
              DO 165,K=1,J8
                IF (RDECE(K) .EQ. NTYPE(J)) RDECE(K)=RDECE(K)+2
165           CONTINUE
            ELSE
              THICKNS(NTYPE(J)+1)=THSAVE    /* THICKNESS GOES ON 2ND GRATING
              IF ((ITHC(NTYPE(J)) .NE. 0) .AND. /*SURFACE IF NOT DECENTER
     *            (ITHC(NTYPE(J)) .NE. 100)) THEN /*RETURN SURFACE.  PICKUP
                 ITHC(NTYPE(J)+1)=ITHC(NTYPE(J))  /*STAYS WITH THICKNESS
                 ITHC(NTYPE(J))=0                 /*SURFACE
              END IF
            END IF
C***  CASE 5: -1<L<1  M=0  -1<N<1
          ELSE IF ((AM(J) .EQ. 0.0) .AND. (ABS(AN(J)) .LT. 1.0)) THEN
            ANGLE=ATAN(AL(J)/AN(J))
            DIF(J)=(DIF(J)/COS(ANGLE))
C***  CASE 6: L=0  M=0  N=+-1.0
          ELSE IF (AL(J) .EQ. 0.0) THEN
            M=M+1
            MESSAGE(M)=5
            MESNUM(M)=NTYPE(J)   /* CANCEL GRATING; -1 AVOIDS PRINTING
            NTYPE(J)=-1          /* IN SUBROUTING OUTPUT2
C***  CASE 7: -1<L<1  -1<M<1  -1<N<1
          ELSE
            IF (DFIRST(NTYPE(J))) THEN  /* DFIRST SIGNALS A DECENTER & RETURN
C                                       /* WHICH TRANSLATES TO 2 SURFACES. THE
              DO 167,K=1,J8             /* GRT TRANSLATES TO 3 SURFACES BETWEEN
C*                                      /* THE DECENTER AND RETURN SURFACES
                IF (RDECE(K) .EQ. (NTYPE(J)+1)) Q=1
167           CONTINUE
              IF (Q .NE. 1)  /*MAKE ROOM FOR ONESHIFT IF RETURN DOESN'T EXIST
     *           CALL SHIFT(NTYPE(J)+1,ISURF,CURVEY,THICKNS,GLASS,
     *            NTYPE,ISTOP,NDECE,NRETUT,NRETUF,NAPERT,NSOLVE,
     *            ICCY,ITHC,IGLC,RDECE,I1,I2,I3,I4,I6,J8)
              CALL ONESHIFT(NTYPE(J),CURVEY,THICKNS,GLASS,
     *         ISTOP,NAPERT,NSOLVE,ICCY,ITHC,IGLC,I1,I4,I6)
C**** SHIFT DATA TO MAKE ROOM FOR 1ST GRATING SURFACE
              ELSE
              Q=0
            END IF
            ANGLE=ATAN(AL(J)/AN(J))
            DIF(J)=(DIF(J)/SIN(ANGLE))
            J9=J9+1
            TILT(J9)=NTYPE(J)
            THETA(J9)=ATAN(AM(J)/AL(J))
            THSAVE=THICKNS(NTYPE(J))
            CALL SHIFT(NTYPE(J),ISURF,CURVEY,THICKNS,GLASS,NTYPE,
     *       ISTOP,NDECE,NRETUT,NRETUF,NAPERT,NSOLVE,ICCY,ITHC,IGLC,
     *       RDECE,I1,I2,I3,I4,I6,J8)
C***  SHIFT DATA TO MAKE ROOM FOR 2ND GRATING SURFACE
            THICKNS(NTYPE(J))=0.0
            CALL SHIFT(NTYPE(J)+1,ISURF,CURVEY,THICKNS,GLASS,NTYPE,
     *       ISTOP,NDECE,NRETUT,NRETUF,NAPERT,NSOLVE,ICCY,ITHC,IGLC,
     *       RDECE,I1,I2,I3,I4,I6,J8)
            RTILT(J9)=NTYPE(J)+1
C***   SHIFT DATA TO MAKE ROOM FOR 3RD GRATING SURFACE
            IF (Q .EQ. 1) THEN
              CALL SHIFT(NTYPE(J)+2,ISURF,CURVEY,THICKNS,GLASS,NTYPE,
     *         ISTOP,NDECE,NRETUT,NRETUF,NAPERT,NSOLVE,ICCY,ITHC,IGLC,
     *         RDECE,I1,I2,I3,I4,I6,J8)     /* SHIFT DATA TO MAKE ROOM FOR
              THICKNS(NTYPE(J)+2)=THSAVE    /* DECENTER RETURN SURFACE IF IT
              IF ((ITHC(NTYPE(J)) .NE. 0) .AND.  /*EXISTS AND PUT THICKNESS HERE
     *            (ITHC(NTYPE(J)) .NE. 100)) THEN
                ITHC(NTYPE(J)+2)=ITHC(NTYPE(J))
                ITHC(NTYPE(J))=0  /*PICKUP UP STAYS WITH THICKNESS SURFACE
              END IF
              DO 170,K=1,J8
                IF (RDECE(K) .EQ. NTYPE(J)) RDECE(K)=RDECE(K)+2
170           CONTINUE
            ELSE
              THICKNS(NTYPE(J)+1)=THSAVE    /* THICKNESS GOES ON 2ND GRATING
              IF ((ITHC(NTYPE(J)) .NE. 0) .AND. /*SURFACE IF NOT DECENTER
     *            (ITHC(NTYPE(J)) .NE. 100)) THEN /*RETURN SURFACE.  PICKUP
                 ITHC(NTYPE(J)+1)=ITHC(NTYPE(J))  /*STAYS WITH THICKNESS
                 ITHC(NTYPE(J))=0                 /*SURFACE
              END IF
            END IF
          END IF
        END IF
175   CONTINUE
C******************************************************************************
C*****CURVATURE CONTROL CODES; Y-AXIS: ICCY
      DO 200,J=1,ISURF
        IF ((ABS(ICCY(J)) .LT. 100) .AND. (ABS(ICCY(J)) .GT. 0)) THEN
          J1=J1+1
          IPK(J1)=J
        ELSE IF ((ICCY(J) .LT. 200) .AND. (ICCY(J) .GT. 100)) THEN
          J3=J3+1
          ICOCYT(J3)=ICCY(J)-100
          ICOCYF(J3)=J
        END IF
200   CONTINUE
      CALL PICKUP(J1,ICCY,IPK,IPKCV1,IPKCV2,ICVA,J2,DUMMY,0)
C*****CURVATURE CONTROL; X-AXIS: ICCX
      J1=0
      DO 215,J=1,I4-1
        IF (TYPE(J) .NE. 'YTO') GOTO 215
        IF ((ABS(ICCX(J)) .LT. 100) .AND. (ABS(ICCX(J)) .GT. 0)) THEN
          J1=J1+1
          IPK(J1)=J
        ELSE IF ((ICCX(J) .LT. 200) .AND. (ICCX(J) .GT. 100)) THEN
          J6=J6+1
          ICOCXT(J6)=ICCX(J)-100
          ICOCXF(J6)=NTYPE(J)
        END IF
215   CONTINUE
      CALL PICKUP(J1,ICCX,IPK,IPKCV1,IPKCV2,ICVA,J2,NTYPE,1)
C******************************************************************************
C*****THICKNESS CONTROL CODES; ITHC
228   J1=0
      DO 230,J=1,ISURF
        IF ((ABS(ITHC(J)) .LT. 100) .AND. (ABS(ITHC(J)) .GT. 0)) THEN
          J1=J1+1
          IPK(J1)=J  /*DETERMINE SURFACES WITH PICKUPS
        END IF
230   CONTINUE
      CALL PICKUP(J1,ITHC,IPK,IPKTH1,IPKTH2,ITHA,J4,DUMMY,0)
C******************************************************************************
C*****GLASS CONTROL CODE: GLC
      J1=0
      DO 260,J=0,ISURF
        IF ((ABS(IGLC(J)) .LT. 100) .AND. (ABS(IGLC(J)) .GT. 0)) THEN
          J1=J1+1
          IPK(J1)=J
        END IF
260   CONTINUE
      CALL PICKUP(J1,IGLC,IPK,IPKGL1,IPKGL2,DUMMY,J5,DUMMY,0)
C*****ASPHERIC CONTROL CODES
C*****IAC
      J1=0
      DO 310,J=1,I4-1
        IF ((ABS(IAC(J)) .LT. 100) .AND. (ABS(IAC(J)) .GT. 0)) THEN
          J1=J1+1
          IPK(J1)=J
        END IF
310   CONTINUE
      CALL PICKUP(J1,IAC,IPK,IPKAD1,IPKAD2,IADA,JD,NTYPE,1)
C*****IBC
      J1=0
      DO 335,J=1,I4-1
        IF ((ABS(IBC(J)) .LT. 100) .AND. (ABS(IBC(J)) .GT. 0)) THEN
          J1=J1+1
          IPK(J1)=J
        END IF
335   CONTINUE
      CALL PICKUP(J1,IBC,IPK,IPKAE1,IPKAE2,IAEA,JE,NTYPE,1)
C*****ICC
      J1=0
      DO 360,J=1,I4-1
        IF ((ABS(ICC(J)) .LT. 100) .AND. (ABS(ICC(J)) .GT. 0)) THEN
          J1=J1+1
          IPK(J1)=J
        END IF
360   CONTINUE
      CALL PICKUP(J1,ICC,IPK,IPKAF1,IPKAF2,IAFA,JF,NTYPE,1)
C*****IDC
      J1=0
      DO 390,J=1,I4-1
        IF ((ABS(IDC(J)) .LT. 100) .AND. (ABS(IDC(J)) .GT. 0)) THEN
          J1=J1+1
          IPK(J1)=J
        END IF
390   CONTINUE
      CALL PICKUP(J1,IDC,IPK,IPKAG1,IPKAG2,IAGA,JG,NTYPE,1)
C*****KC
      J1=0
      DO 412,J=1,I4-1
        IF ((ABS(KC(J)) .LT. 100) .AND. (ABS(KC(J)) .GT. 0)) THEN
          J1=J1+1
          IPK(J1)=J
        END IF
412   CONTINUE
      CALL PICKUP(J1,KC,IPK,IPKCC1,IPKCC2,ICCA,JC,NTYPE,1)
C******************************************************************************
C*****DECENTER CONTROL CODES; IXDC
      J1=0
      DO 420,J=1,I2-1
        IF ((ABS(IXDC(J)) .LT. 100) .AND. (ABS(IXDC(J)) .GT. 0)) THEN
          J1=J1+1
          IPK(J1)=J
        END IF
420   CONTINUE
      CALL PICKUP(J1,IXDC,IPK,IPKX1,IPKX2,IXA,JX,NDECE,1)
C*****IYDC
      J1=0
      DO 450,J=1,I2-1
        IF ((ABS(IYDC(J)) .LT. 100) .AND. (ABS(IYDC(J)) .GT. 0)) THEN
          J1=J1+1
          IPK(J1)=J
        END IF
450   CONTINUE
      CALL PICKUP(J1,IYDC,IPK,IPKY1,IPKY2,IYA,JY,NDECE,1)
C*****IADC
      J1=0
      DO 480,J=1,I2-1
        IF ((ABS(IADC(J)) .LT. 100) .AND. (ABS(IADC(J)) .GT. 0)) THEN
          J1=J1+1
          IPK(J1)=J
        END IF
480   CONTINUE
      CALL PICKUP(J1,IADC,IPK,IPKA1,IPKA2,IAA,JA,NDECE,1)
C*****IBDC
      J1=0
      DO 510,J=1,I2-1
        IF ((ABS(IBDC(J)) .LT. 100) .AND. (ABS(IBDC(J)) .GT. 0)) THEN
          J1=J1+1
          IPK(J1)=J
        END IF
510   CONTINUE
      CALL PICKUP(J1,IBDC,IPK,IPKB1,IPKB2,IBA,JB,NDECE,1)
C*****ICDC
      J1=0
      DO 540,J=1,I2-1
        IF ((ABS(ICDC(J)) .LT. 100) .AND. (ABS(ICDC(J)) .GT. 0)) THEN
          J1=J1+1
          IPK(J1)=J
        END IF
540   CONTINUE
      CALL PICKUP(J1,ICDC,IPK,IPKG1,IPKG2,IGA,JM,NDECE,1)
C******************************************************************************
C*****WAVE LENGTHS AND WEIGHTS
      WVW1=WLF1/1000.0   /*CONVERT TO MICRONS
      WVW2=WLF2/1000.0  /*DEFAULT
      IWT1=IWTW1
      IWT2=IWTW2
      IF (WLF5 .GT. 0.0) THEN
        WVW1=WLF3/1000.0
        WVW2=WLF4/1000.0
        WVW3=WLF2/1000.0
        WVW4=WLF5/1000.0
        WVW5=WLF1/1000.0
        IWT1=IWTW3
        IWT2=IWTW4
        IWT3=IWTW2
        IWT4=IWTW5
        IWT5=IWTW1
      ELSE IF (WLF3 .GT. 0.0) THEN
        WVW1=WLF2/1000.0
        WVW2=WLF3/1000.0
        WVW3=WLF1/1000.0
        WVW4=WLF4/1000.0
        IWT1=IWTW2
        IWT2=IWTW3
        IWT3=IWTW1
        IWT4=IWTW4
      END IF
C******************************************************************************
C*****PRIVATE CATALOG WAVE LENGTHS AND INDICES OF REFRACTION
      DO 600,J=1,I5
        W1(J)=CATWL1(J)/1000.0
        W2(J)=CATWL2(J)/1000.0
        N1(J)=RFND1(J)
        N2(J)=RFND2(J)
        IF (CATWL5(J) .GT. 0.0) THEN
          W1(J)=CATWL3(J)/1000.0
          W2(J)=CATWL4(J)/1000.0
          W3(J)=CATWL2(J)/1000.0
          W4(J)=CATWL5(J)/1000.0
          W5(J)=CATWL1(J)/1000.0
          N1(J)=RFND3(J)
          N2(J)=RFND4(J)
          N3(J)=RFND2(J)
          N4(J)=RFND5(J)
          N5(J)=RFND1(J)
        ELSE IF (CATWL3(J) .GT. 0.0) THEN
          W1(J)=CATWL2(J)/1000.0
          W2(J)=CATWL3(J)/1000.0
          W3(J)=CATWL1(J)/1000.0
          W4(J)=CATWL4(J)/1000.0
          N1(J)=RFND2(J)
          N2(J)=RFND3(J)
          N3(J)=RFND1(J)
          N4(J)=RFND4(J)
        END IF
600   CONTINUE
C******************************************************************************
C*****REFRACTIVE INDICES
      DO 620,J=1,I7
        TWL1(J)=WL1(J)/1000.0
        TWL2(J)=WL2(J)/1000.0
        TIND1(J)=IND1(J)
        TIND2(J)=IND2(J)
        IF (WL5(J) .GT. 0.0) THEN
          TWL1(J)=WL3(J)/1000.0
          TWL2(J)=WL4(J)/1000.0
          TWL3(J)=WL2(J)/1000.0
          TWL4(J)=WL5(J)/1000.0
          TWL5(J)=WL1(J)/1000.0
          TIND1(J)=IND3(J)
          TIND2(J)=IND4(J)
          TIND3(J)=IND2(J)
          TIND4(J)=IND5(J)
          TIND5(J)=IND1(J)
        ELSE IF (WL3(J) .GT. 0.0) THEN
          TWL1(J)=WL2(J)/1000.0
          TWL2(J)=WL3(J)/1000.0
          TWL3(J)=WL1(J)/1000.0
          TWL4(J)=WL4(J)/1000.0
          TIND1(J)=IND2(J)
          TIND2(J)=IND3(J)
          TIND3(J)=IND1(J)
          TIND4(J)=IND4(J)
        END IF
620   CONTINUE
C******************************************************************************
C*****UNITS
      IF (DIM .EQ. 'I   ') THEN
        UNITS='INCHES'
      ELSE IF (DIM .EQ. 'M   ') THEN
        UNITS='MM'
      ELSE IF (DIM .EQ. 'C   ') THEN
        UNITS='CM'
      END IF
C******************************************************************************
C*****GLASS
      DO 640,J=0,ISURF
        IF ((GLASS(J)(8:12) .EQ. 'OHARA') .OR.
     *     (GLASS(J)(8:13) .EQ. 'SCHOTT') .OR.
     *     (GLASS(J)(8:11) .EQ. 'HOYA')) THEN
          GL(J)=GLASS(J)(8:13)//' '//GLASS(J)(1:6)
        ELSE IF ((GLASS(J)(1:3) .EQ. 'AIR') .OR.
     *      (GLASS(J)(1:4) .EQ. 'REFL')) THEN
          GL(J)=GLASS(J)
          ELSE IF (GLASS(J)(1:2) .EQ. '  ') THEN
            GL(J)='AIR'
          ELSE
          GL(J)='1'
          DO 630,K=1,I5
            IF (GLASS(J) .EQ. MATRL(K)) INDICE(J)=K
630       CONTINUE
        END IF
640   CONTINUE
C******************************************************************************
C*****MATRL GLASS
      DO 645,J=1,I7
        IF ((CATALOG(J)(8:12) .EQ. 'OHARA') .OR.
     *      (CATALOG(J)(8:13) .EQ. 'SCHOTT') .OR.
     *      (CATALOG(J)(8:11) .EQ. 'HOYA'))
     *      CATALOG(J)=CATALOG(J)(8:13)//' '//CATALOG(J)(1:6)
645   CONTINUE
C******************************************************************************
C*****APERTURES
      K=0
      DO 650,J=1,I1-1
        K=K+1
        IF (APERT(J) .EQ. 'CIR') THEN
          ICIR(K)=NAPERT(J)
          F1(K)=F1(J)
        ELSE IF (APERT(J) .EQ. 'REX') THEN
          IRECT(K)=NAPERT(J)
          F2(K)=F1(J)
          J=J+1
          F1(K)=F1(J)
        ELSE IF (APERT(J) .EQ. 'REY') THEN
          IRECT(K)=NAPERT(J)
          F1(K)=F1(J)
          J=J+1
          F2(K)=F1(J)
        ELSE IF (APERT(J) .EQ. 'ELX') THEN
          IELIP(K)=NAPERT(J)
          F2(K)=F1(J)
          J=J+1
          F1(K)=F1(J)
        ELSE IF (APERT(J) .EQ. 'ELY') THEN
          IELIP(K)=NAPERT(J)
          F1(K)=F1(J)
          J=J+1
          F2(K)=F1(J)
        END IF
650   CONTINUE
      NUMA=K
C******************************************************************************
C*****SOLVES
      DO 800,J=1,I6-1
        IF (SOLVE1(J) .EQ. 'CUY') GOTO 770
        IF (SOLVE1(J) .EQ. 'CUX') GOTO 780
        IF (SOLVE1(J) .EQ. 'PIM') SOLVE(J)='PY'
C*****THICKNESS SOLVES
        IF (SOLVE2(J) .EQ. 'MRY') THEN
          SOLVE(J)='PY'
        ELSE IF (SOLVE2(J) .EQ. 'CRY') THEN
          SOLVE(J)='PCY'
        ELSE IF (SOLVE2(J) .EQ. 'MRX') THEN
          SOLVE(J)='PX'
        ELSE IF (SOLVE2(J) .EQ. 'CRX') THEN
          SOLVE(J)='PCX'
        END IF
        GOTO 800
C*****CURVATURE SOLVES: Y-AXIS
770     IF (SOLVE2(J) .EQ. 'MRY') THEN
          SOLVE(J)='PUY'
        ELSE IF (SOLVE2(J) .EQ. 'CRY') THEN
          SOLVE(J)='PUCY'
        ELSE IF (SOLVE2(J) .EQ. 'IMY') THEN
          SOLVE(J)='PIY'
        ELSE IF (SOLVE2(J) .EQ. 'ICY') THEN
          SOLVE(J)='PICY'
        ELSE IF (SOLVE2(J) .EQ. 'AMY') THEN
          SOLVE(J)='APY'
        ELSE IF (SOLVE2(J) .EQ. 'ACY') THEN
          SOLVE(J)='APCY'
        END IF
        GOTO 800
C*****CURVATURE SOLVES: X-AXIS
780     IF (SOLVE2(J) .EQ. 'MRX') THEN
          SOLVE(J)='PUX'
        ELSE IF (SOLVE2(J) .EQ. 'CRX') THEN
          SOLVE(J)='PUCX'
        ELSE IF (SOLVE2(J) .EQ. 'IMX') THEN
          SOLVE(J)='PIX'
        ELSE IF (SOLVE2(J) .EQ. 'ICX') THEN
          SOLVE(J)='PICX'
        ELSE IF (SOLVE2(J) .EQ. 'AMX') THEN
          SOLVE(J)='APX'
        ELSE IF (SOLVE2(J) .EQ. 'ACX') THEN
          SOLVE(J)='APCX'
        END IF
800   CONTINUE
C******************************************************************************
C*****ANALYSIS DATA
      UCHIEF=UCHIEF*(360/(2*3.1415927))
      RETURN
      END
      SUBROUTINE OUTPUT2
C
C*****THIS SUBROUTINE WRITES AN ACCOSV LENS DECK
C
C** COMMON BLOCK BOTH DECLARATIONS
      CHARACTER*4 SOLVE(40)
      CHARACTER*13 GLASS(0:225)
      CHARACTER*64 TITLE
      INTEGER*4 I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,M,ISTOP,IREF,ISURF
      INTEGER*4 NAPERT(225),NDECE(100),NSOLVE(40),NUMA,MESSAGE(20)
      REAL*4 DIF(66)
      REAL*8 ADE(100),BDE(100),CDE(100),XDE(100),YDE(100),CURVEY(0:225)
      REAL*8 THICKNS(0:225),RK(66),A(66),B(66),C(66),D(66),SOLVF1(40)
      REAL*8 F1(225)
      LOGICAL AFO,IC(66),CUF(66)
C** COMMON BLOCK ACCOSV DECLARATIONS
      CHARACTER*6 UNITS
      INTEGER*4 IORDER(66),IWT1,IWT2,IWT3,IWT4,IWT5
      REAL*4 WVW1,WVW2,WVW3,WVW4,WVW5,WT1,WT2,WT3,WT4,WT5,THETA(66)
      REAL*4 RN1
      REAL*8 N1(20),N2(20),N3(20),N4(20),N5(20),F2(225)
C** COMMON BLOCK CAONLY DECLARATIONS
      CHARACTER*3 SURFMES(20),SOLVE1(40),SOLVE2(40)
      CHARACTER*4 TYPE(66)
      CHARACTER*13 CATALOG(20),MATRL(20),GL(0:225)
      CHARACTER*24 SUBMES4(20)
      INTEGER*4 NTYPE(66),NRETUT(100),NRETUF(100),IPKCV1(200)
      INTEGER*4 IPKAD1(200),IPKAD2(200),IPKAE1(200),IPKAE2(200)
      INTEGER*4 IPKAF1(200),IPKAF2(200),IPKAG1(200),IPKAG2(200)
      INTEGER*4 IPKA1(200),IPKA2(200),IPKB1(200),IPKB2(200),IPKG1(200)
      INTEGER*4 IPKG2(200),IPKX1(200),IPKX2(200),IPKY1(200),IPKY2(200)
      INTEGER*4 IPKGL1(200),IPKGL2(200),IPKTH1(200),IPKTH2(200)
      INTEGER*4 IPKCC1(200),IPKCC2(200),ICCA(200),ICVA(200),ITHA(200)
      INTEGER*4 IGLA(200),IAEA(200),IAFA(200),IAGA(200),IADA(200)
      INTEGER*4 IXA(200),IYA(200),IAA(200),IBA(200),IGA(200),J1,J2,J3
      INTEGER*4 J4,J5,J6,J7,J8,J9,JE,JF,JG,JD,JX,JY,JA,JB,JM
      INTEGER*4 INDICE(225),ICIR(225),IRECT(225),IELIP(225),ICOCYF(20)
      INTEGER*4 ICOCYT(20),ICOCXF(20),ICOCXT(20),TILT(66),RTILT(66)
      INTEGER*4 RDECE(100),MESNUM(20),IPKCV2(200)
      REAL*4 WL1(20),WL2(20),WL3(20),WL4(20),WL5(20),WL6(20),WL7(20)
      REAL*4 TWL1(20),TWL2(20),TWL3(20),TWL4(20),TWL5(20)
      REAL*4 CATWL1(20),CATWL2(20),CATWL3(20),CATWL4(20),CATWL5(20)
      REAL*4 CATWL6(20),CATWL7(20),W1(20),W2(20),W3(20),W4(20),W5(20)
      REAL*4 IND1(20),IND2(20),IND3(20),IND4(20),IND5(20),TIND1(20)
      REAL*4 TIND2(20),TIND3(20),TIND4(20),TIND5(20)
      REAL*8 UMARG,YMARG,UCHIEF,CUX(30),RADE(100),RBDE(100)
      REAL*8 RCDE(100),RXDE(100),RYDE(100)
      LOGICAL VIGNET,TEL,RETURN(100),ZMFLAG
C** LOCAL DECLARATIONS
      CHARACTER*4 FLAG1,FLAG2
      REAL*45 FLAG4,FLAG3
C
      COMMON /BOTH/I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,GLASS,MESSAGE,M,
     *        ISTOP,IREF,ISURF,AFO,NAPERT,NDECE,F1,DIF,ADE,BDE,CDE,XDE,
     *        YDE,CURVEY,THICKNS,RK,A,B,C,D,IC,CUF,NSOLVE,SOLVF1,SOLVE,
     *        TITLE,NUMA
      COMMON /ACCOSV/IORDER,WVW1,WVW2,WVW3,WVW4,WVW5,WT1,WT2,WT3,WT4,
     *        WT5,IWT1,IWT2,IWT3,IWT4,IWT5,THETA,F2,RN1,UNITS,N1,
     *        N2,N3,N4,N5
      COMMON /CAONLY/UMARG,YMARG,UCHIEF,YCHIEF,TYPE,NTYPE,NRETUT,
     *        NRETUF,CATWL1,CATWL2,CATWL3,CATWL4,CATWL5,CATWL6,CATWL7,
     *        CUX,VIGNET,TEL,RETURN,MATRL,SOLVE1,SOLVE2,ZMFLAG,SURFMES,
     *        CATALOG,WL1,WL2,WL3,WL4,WL5,WL6,WL7,IND1,IND2,IND3,IN4,
     *        IND5,TWL1,TWL2,TWL3,TWL4,TWL5,TIND1,TIND2,TIND3,TIND4,
     *        TIND5,GL,IPKCV1,IPKCV2,IPKAD1,IPKAD2,IPKAE1,IPKAE2,
     *        IPKAF1,IPKAF2,IPKAG1,IPKAG2,IPKA1,IPKA2,IPKB1,IPKB2,
     *        IPKG1,IPKG2,IPKX1,IPKX2,IPKY1,IPKY2,IPKTH1,IPKTH2,IPKCC1,
     *        IPKCC2,ICCA,ICVA,ITHA,IGLA,IAEA,IAFA,IAGA,IADA,IXA,IYA,
     *        IAA,IBA,IGA,J1,J2,J3,J4,J5,J6,J7,J8,J9,JE,JF,JG,JD,JX,JY,
     *        JA,JB,JM,INDICE,ICIR,IRECT,IELIP,ICOCYF,ICOCYT,ICOCXF,
     *        ICOCXT,TILT,RTILT,W1,W2,W3,W4,W5,RDECE,RADE,RBDE,RCDE,
     *        RXDE,RYDE,MESNUM,SUBMES4
C******************************************************************************
C*****FORMAT STATEMENTS
  2   FORMAT(1X,A8,F14.7,2X,F14.7)
  4   FORMAT(1X,A8)
  6   FORMAT(1X,A6,A60)
  8   FORMAT(1X,A8,E14.7)
  9   FORMAT(1X,A8,F14.7)
 10   FORMAT(1X,A8,6X,F8.6,3X,F8.6,3X,F8.6,3X,F8.6,3X,F8.6)
 11   FORMAT(1X,A8,I4)
 12   FORMAT(1X,A6,A6,A1)
 13   FORMAT(1X,A8,10X,I4,7X,I4,7X,I4,7X,I4,7X,I4)
 14   FORMAT(1X,A11)
 16   FORMAT(1X,A14,F8.6,3X,F8.6,3X,F8.6,3X,F8.6,3X,F8.6)
 18   FORMAT(1X,A8,E14.7,1X,E14.7,1X,E14.7,1X,E14.7)
 20   FORMAT(1X,A8,F14.7,2X,F14.7,2X,F14.7)
 22   FORMAT(1X,A13,I4,2X,I4)
 24   FORMAT(1X,A13,I4)
 26   FORMAT(1X,A12,2X,I4)
 28   FORMAT(1X,A10,F12.7)
 30   FORMAT(1X,A10,F12.7,4X,F12.7)
 31   FORMAT(1X,A4,4X,F14.7)
 32   FORMAT(1X,A29)
 34   FORMAT(1X,A13)
 36   FORMAT(1X,A6,A6,2X,F8.6,3X,F8.6,3X,F8.6,3X,F8.6,3X,F8.6)
 38   FORMAT(1X,A46)
 40   FORMAT(1X,A61)
 42   FORMAT(1X,A47)
 44   FORMAT(1X,A24,A3,A33)
 46   FORMAT(1X,A32,I4,A20)
 48   FORMAT(1X,A75)
 49   FORMAT(1X,A47,A15)
 50   FORMAT(1X,A8,A24)
C******************************************************************************
C*****STANDARD DATA - WRITTEN ONCE PER LENS DECK
      WRITE(5,6)'LENS  ',TITLE
      WRITE(5,9)'SAY     ',YMARG
      WRITE(5,2)'SCY FANG',UCHIEF,YCHIEF
      WRITE(5,10)'WV      ',WVW1,WVW2,WVW3,WVW4,WVW5
      IF (IREF .GT. 0) WRITE(5,11)'CW      ',IREF
      IF (DIM .NE. ' ') WRITE(5,12)'UNITS ',UNITS
      IF (AFO) WRITE(5,14)'MODE AFOCAL'
C******************************************************************************
C*****MAIN LOOP IS EXECUTED ONCE FOR EACH SURFACE
      DO 500,L=0,ISURF
        WRITE(5,8)'CV      ',CURVEY(L)
        WRITE(5,8)'TH      ',THICKNS(L)
        IF (L .EQ. ISTOP) THEN
          WRITE(5,4)'ASTOP   '
          WRITE(5,4)'REFS    '
        END IF
        DO 95,K=1,I5
          IF (CATALOG(K) .EQ. GLASS(L)) THEN
            WRITE(5,16)'MELT WV       ',W1(K),W2(K),W3(K),W4(K),W5(K)
            WRITE(5,16)'MELT INDICES  ',N1(K),N2(K),N3(K),N4(K),N5(K)
          END IF
 95     CONTINUE
C******************************************************************************
C*****TILTS AND RTILTS
        DO 100,K=1,J9
          IF (TILT(K) .EQ. L) WRITE(5,20)'TILT    ',0.0,0.0,THETA(K)
          IF (RTILT(K) .EQ. L) WRITE(5,20)'RTILT   ',0.0,0.0,THETA(K)
100     CONTINUE
C******************************************************************************
C*****SPECIAL SURFACES
        DO 200,K=1,I4-1
          IF (NTYPE(K) .EQ. L) THEN
            IF (TYPE(K) .EQ. 'CYL') GOTO 150
            WRITE(5,18)'ASPH    ',A(K),B(K),C(K),D(K)
            WRITE(5,9)'CC      ',RK(K)
            IF (IC(K)) WRITE(5,4)'ASI     '
            IF (CUF(K)) WRITE(5,4)'FRNL    '
            IF (TYPE(K) .EQ. 'YTO') THEN
150           WRITE(5,9)'CVY     ',CUX(K)
            ELSE IF (TYPE(K) .EQ. 'GRT') THEN
              WRITE(5,9)'GRATY   ',DIF(K)
              WRITE(5,13)'GORD    ',IORDER(K),IORDER(K),IORDER(K),
     *          IORDER(K),IORDER(K)
             END IF
          END IF
200     CONTINUE
C******************************************************************************
C*****PICK UP CONTROL CODES
C*****CURVATURE PICKUPS
        DO 220,K=1,J2
          IF (IPKCV2(K) .EQ. L) WRITE(5,22)'PIKUP CV     ',IPKCV1(K),
     *      ICVA(K)
220     CONTINUE
        DO 225,K=1,J3
          IF (ICOCYF(K) .EQ. L) WRITE(5,24)'COCY         ',ICOCYT(K)
225     CONTINUE
        DO 230,K=1,J6
          IF (ICOCXF(K) .EQ. L) WRITE(5,24)'COCX         ',ICOCXT(K)
230     CONTINUE
C*****THICKNESS PICKUPS
        DO 235,K=1,J4
          IF (IPKTH2(K) .EQ. L) WRITE(5,22)'PIKUP TH     ',IPKTH1(K),
     *      ITHA(K)
235     CONTINUE
C*****GLASS PICKUPS
        DO 240,K=1,J5
          IF (IPKGL2(K) .EQ. L) WRITE(5,24)'PIKUP GLASS  ',IPKGL1(K)
240     CONTINUE
C*****ASPHERIC PICKUPS
        DO 245,K=1,JD
          IF (IPKAD2(K) .EQ. L) WRITE(5,22)'PIKUP AD     ',IPKAD1(K),
     *      IADA(K)
245     CONTINUE
        DO 250,K=1,JE
          IF (IPKAE2(K) .EQ. L) WRITE(5,22)'PIKUP AE     ',IPKAE1(K),
     *      IAEA(K)
250     CONTINUE
        DO 255,K=1,JF
          IF (IPKAF2(K) .EQ. L) WRITE(5,22)'PIKUP AF     ',IPKAF1(K),
     *      IAFA(K)
255     CONTINUE
        DO 260,K=1,JG
          IF (IPKAG2(K) .EQ. L) WRITE(5,22)'PIKUP AG     ',IPKAG1(K),
     *      IAGA(K)
260     CONTINUE
        DO 265,K=1,JC
          IF (IPKCC2(K) .EQ. L) WRITE(5,22)'PIKUP CC     ',IPKCC1(K),
     *      ICCA(K)
265     CONTINUE
C*****DECENTER PICKUPS
        DO 270,K=1,JX
          IF (IPKX2(K) .EQ. L) WRITE(5,22)'PIKUP XD     ',IPKX1(K),
     *      IXA(K)
270     CONTINUE
        DO 275,K=1,JY
          IF (IPKY2(K) .EQ. L) WRITE(5,22)'PIKUP YD     ',IPKY1(K),
     *      IYA(K)
275     CONTINUE
        DO 280,K=1,JA
          IF (IPKA2(K) .EQ. L) WRITE(5,22)'PIKUP ALPHA  ',IPKA1(K),
     *      IAA(K)
280     CONTINUE
        DO 285,K=1,JB
          IF (IPKB2(K) .EQ. L) WRITE(5,22)'PIKUP BETA   ',IPKB1(K),
     *      IBA(K)
285     CONTINUE
        DO 290,K=1,JM
          IF (IPKG2(K) .EQ. L)WRITE(5,22)'PIKUP GAMMA  ',IPKG1(K),
     *      IGA(K)
290     CONTINUE
C******************************************************************************
C*****DECENTERED SURFACES; INITIAL DECENTER
        DO 300,K=1,I2-1
          IF (NDECE(K) .EQ. L) THEN
           WRITE(5,2)'DEC     ',YDE(K),XDE(K)
           WRITE(5,20)'TILT    ',ADE(K),BDE(K),CDE(K)
          END IF
300     CONTINUE
C******************************************************************************
C*****DECENTERED SURFACES WITH RETURNS
        DO 305,K=1,J8
          IF (RDECE(K) .EQ. L) THEN
            WRITE(5,20)'RTILT   ',RADE(K),RBDE(K),RCDE(K)
            WRITE(5,2)'DEC     ',RYDE(K),RXDE(K)
          END IF
305     CONTINUE
C******************************************************************************
C*****RETURN ONLY SURFACE
        IF (I2 .LE. 1) GOTO 331
        DO 330,J=1,I3-1
         IF (NRETUF(J) .EQ. L) THEN           /* TRACING BACK THROUGH EACH
          DO 310,KK=(I2-1),1,-1               /* TILT AND DECNTER AND REVERSING
            IF ((NDECE(KK) .LT. NRETUF(J)) .AND. /* THEM IF A RETURN HAS NOT
     *        (NDECE(KK) .GT. NRETUT(J)) .AND.   /* OCCURRED
     *        (.NOT. RETURN(KK))) THEN
                WRITE(5,20)'RTILT   ',ADE(KK),BDE(KK),CDE(KK)
                WRITE(5,2)'DEC     ',-YDE(KK),-XDE(KK)
              END IF
310         CONTINUE
         END IF
330     CONTINUE
C******************************************************************************
C*****APERTURES
331     DO 335,K=1,NUMA
          IF (F1(K) .EQ. ABS(F1(K))) GOTO 332
            IF (ICIR(K) .EQ. L) THEN
              WRITE(5,28)'COBS      ',-F1(K)
            ELSE IF (IRECT(K) .EQ. L) THEN
              WRITE(5,30)'COBS RECT ',-F1(K),-F2(K)
            ELSE IF (IELIP(K) .EQ. L) THEN
              WRITE(5,30)'COBS ELIP ',-F1(K),-F2(K)
            END IF
          GOTO 335
332         IF (ICIR(K) .EQ. L) THEN
              WRITE(5,28)'CLAP      ',F1(K)
            ELSE IF (IRECT(K) .EQ. L) THEN
              WRITE(5,30)'CLAP RECT ',F1(K),F2(K)
            ELSE IF (IELIP(K) .EQ. L) THEN
              WRITE(5,30)'CLAP ELIP ',F1(K),F2(K)
            END IF
335     CONTINUE
C******************************************************************************
C*****SOLVES
        DO 350,K=1,I6-1
          IF (NSOLVE(K) .EQ. L) WRITE(5,31)SOLVE(K),SOLVF1(K)
350     CONTINUE
C******************************************************************************
C*****MATERIAL
      IF (GL(L)(1:1) .NE. '1') THEN
        WRITE(5,34)GL(L)
      ELSE
        WRITE(5,36)'GLASS ',GLASS(L)(1:6),TIND1(INDICE(L)),
     *   TIND2(INDICE(L)),TIND3(INDICE(L)),TIND4(INDICE(L)),
     *   TIND5(INDICE(L))
      END IF
500   CONTINUE  /* END MAIN LOOP
C******************************************************************************
C*****END LENS
      WRITE(5,4)'EOS     '
      IF (IWT1 .GT. 0.0) WRITE(5,10)'SPTWT   ',IWT1,IWT2,IWT3,IWT4,IWT5
C*****WRITE MESSAGES
      WRITE(5,32)'C  .....END OF LENS DECK.....'
      DO 550,K=1,M-1
        IF (MESSAGE(K) .EQ. 1) THEN
          WRITE(5,38)'C  .....Vignetting is not available in ACCOSV.'
        ELSE IF (MESSAGE(K) .EQ. 2) THEN
          WRITE(5,40)'C  .....Telecentric System option is not ',
     *     'available in ACCOSV.'
        ELSE IF (MESSAGE(K) .EQ. 3) THEN
          WRITE(5,42)'C  .....ZOOM option is not available in ACCOSV.'
        ELSE IF (MESSAGE(K) .EQ. 4) THEN
          WRITE(5,44)'C  .....Special Surface ',SURFMES(K),
     *      ' cannot be translated for ACCOSV.'
        ELSE IF (MESSAGE(K) .EQ. 5) THEN
          WRITE(5,46)'C  .....Check grating on surface',MESNUM(K),
     *      ' and enter it manually.'
        ELSE IF (MESSAGE(K) .EQ. 6) THEN
          WRITE(5,48)'C  .....Zero thickness on surface 0 is not ',
     *      'allowed.  Surface 0 was deleted.'
        ELSE IF (MESSAGE(K) .EQ. 7) THEN
          WRITE(5,49)'C  .....The following aperture data line cannot',
     *     ' be translated.'
          WRITE(5,50)'C  .....',SUBMES4(K)
        END IF
550   CONTINUE
      RETURN
      END
C
      SUBROUTINE SHIFT(L,ISURF,CURVEY,THICKNS,GLASS,NTYPE,ISTOP,
     *  NDECE,NRETUT,NRETUF,NAPERT,NSOLVE,ICCY,ITHC,IGLC,RDECE,
     *  I1,I2,I3,I4,I6,J8)
C*****THIS SUBROUTINE SHIFTS ALL ARRAY VALUES READ FROM THE INPUT FILE
C*****ONE POSITION TO ALLOW FOR AN EXTRA SURFACE TO BE ADDED. THIS NEED
C*****IS CREATED BY TILTS WITH RETURNS AND GRATINGS.
C
      INTEGER*4 L,ISURF,NTYPE(66),ISTOP,NDECE(100),NRETUT(100)
      INTEGER*4 NRETUF(100),NAPERT(225),NSOLVE(40),ICCY(0:225)
      INTEGER*4 ITHC(0:225),IGLC(0:225),RDECE(100),I1,I2,I3,I4,I6,J8
      REAL*8 CURVEY(0:225),THICKNS(0:225)
      CHARACTER*13 GLASS(0:225)
C
      DO 100,K=ISURF,L,-1
        CURVEY(K+1)=CURVEY(K)
        THICKNS(K+1)=THICKNS(K)
        GLASS(K+1)=GLASS(K)
        ICCY(K+1)=ICCY(K)
        ITHC(K+1)=ITHC(K)
        IGLC(K+1)=IGLC(K)
100   CONTINUE
      ISURF=ISURF+1
      CURVEY(L)=0.0
      THICKNS(L)=0.0
      ICCY(L)=0
      ITHC(L)=0
      IGLC(L)=0
      GLASS(L)='        '
      IF (ISTOP .GE. L) ISTOP=ISTOP+1
      DO 175,K=1,I3-1
        IF (NRETUT(K) .GE. L) NRETUT(K)=NRETUT(K)+1
        IF (NRETUF(K) .GE. L) NRETUF(K)=NRETUF(K)+1
175   CONTINUE
      DO 200,K=1,I1-1
        IF (NAPERT(K) .GE. L) NAPERT(K)=NAPERT(K)+1
200   CONTINUE
      DO 225,K=1,I6-1
        IF (NSOLVE(K) .GE. L) NSOLVE(K)=NSOLVE(K)+1
225   CONTINUE
      DO 250,K=1,J8
        IF (RDECE(K) .GE. L) RDECE(K)=RDECE(K)+1
250   CONTINUE
      DO 260,K=1,I2-1
        IF (NDECE(K) .GE. L) NDECE(K)=NDECE(K)+1
260   CONTINUE
      DO 275,K=1,I4-1
        IF (NTYPE(K) .GE. L) NTYPE(K)=NTYPE(K)+1
275   CONTINUE
      RETURN
      END
C
      SUBROUTINE ONESHIFT(L,CURVEY,THICKNS,GLASS,ISTOP,
     *  NAPERT,NSOLVE,ICCY,ITHC,IGLC,I1,I4,I6)
C*****THIS SUBROUTINE SHIFTS DATA FROM ONE SURFACE TO THE NEXT SURFACE.
C*****THIS IS A SINGLE SURFACE SHIFT. THIS NEED IS CREATED BY A DECENTER
C*****WITH A GRATING.
C
      INTEGER*4 L,ISTOP,NAPERT(225),NSOLVE(40),ICCY(0:225)
      INTEGER*4 ITHC(0:225),IGLC(0:225),I1,I4,I6
      REAL*8 CURVEY(0:225),THICKNS(0:225)
      CHARACTER*13 GLASS(0:225)
C
      CURVEY(L+1)=CURVEY(L)
      THICKNS(L+1)=THICKNS(L)
      GLASS(L+1)=GLASS(L)
      ICCY(L+1)=ICCY(L)
      ITHC(L+1)=ITHC(L)
      IGLC(L+1)=IGLC(L)
      CURVEY(L)=0.0
      THICKNS(L)=0.0
      ICCY(L)=0
      ITHC(L)=0
      IGLC(L)=0
      GLASS(L)='        '
      IF (ISTOP .EQ. L) ISTOP=ISTOP+1
      DO 200,K=1,I1-1
        IF (NAPERT(K) .EQ. L) NAPERT(K)=NAPERT(K)+1
200   CONTINUE
      DO 225,K=1,I6-1
        IF (NSOLVE(K) .EQ. L) NSOLVE(K)=NSOLVE(K)+1
225   CONTINUE
      L=L+1
      RETURN
      END
C
      SUBROUTINE PICKUP(J1,ICODE,IPK,IPK1,IPK2,IA,J,N,L)
C*****THIS SUBROUTINE CONVERTS CONTROL CODES TO PICKUS BY FINDING THE SURFACE
C*****TO PICKUP FROM AND THE SURFACE TO PICKUP TO
      INTEGER*4 J1,J,ICODE(0:225),IPK(200),IPK1(200),IPK2(200),IA(200)
      INTEGER*4 N(100),L
C
      DO 200,K=1,J1
        DO 100,KK=(K+1),J1
          J=J+1
          IF (ABS(ICODE(IPK(K)-L)) .EQ. ABS(ICODE(IPK(KK)-L))) THEN
            IF (N(1) .EQ. 0) THEN /* DUMMY ARRAY PASSED
              IPK1(J)=IPK(K)              /* L CORRECTS FOR THE DIFFERENT
              IPK2(J)=IPK(KK)            /* DIMENSIONS OF ICCY,ITH,IGLC
            ELSE                        /* COMPARED TO THE OTHER CONTROL
              IPK1(J)=N(IPK(K))          /* CODE ARRAYS.
              IPK2(J)=N(IPK(KK))
            END IF
          ELSE
            GOTO 100
          END IF
          IF (ICODE(IPK(K)-L) .NE. ICODE(IPK(KK)-L)) THEN
            IA(J)=-1
          ELSE
            IA(J)=1
          END IF
          ICODE(IPK(KK)-L)=0 /*RESET TO AVOID A DOUBLE PICKUP
100     CONTINUE
200   CONTINUE
      RETURN
      END
C
C
      SUBROUTINE ZEROSHIFT(ISURF,CURVEY,THICKNS,GLASS,NTYPE,ISTOP,
     *  NDECE,NRETUT,NRETUF,NAPERT,NSOLVE,ICCY,ITHC,IGLC,I1,I2,I3,
     *  I4,I6)
C*****THIS SUBROUTINE SHIFTS ALL SURFACES FORWARD SO THAT SURFACE ONE
C*****BECOMES SURFACE 0, 2 BECOMES 1, ETC.  THIS IS NECESSARY IF THE
C*****THICKNESS ON SURFACE 0 EQUALS 0.
C
      INTEGER*4 ISURF,NTYPE(66),ISTOP,NDECE(100),NRETUT(100)
      INTEGER*4 NRETUF(100),NAPERT(225),NSOLVE(40),ICCY(0:225)
      INTEGER*4 ITHC(0:225),IGLC(0:225),I1,I2,I3,I4,I6
      REAL*8 CURVEY(0:225),THICKNS(0:225)
      CHARACTER*13 GLASS(0:225)
C
      DO 100,K=0,ISURF-1
        CURVEY(K)=CURVEY(K+1)
        THICKNS(K)=THICKNS(K+1)
        GLASS(K)=GLASS(K+1)
        ICCY(K)=ICCY(K+1)
        ITHC(K)=ITHC(K+1)
        IGLC(K)=IGLC(K+1)
100   CONTINUE
      ISURF=ISURF-1
      ISTOP=ISTOP-1
      DO 150,K=1,I2-1
        NDECE(K)=NDECE(K)-1
150   CONTINUE
      DO 175,K=1,I3-1
        NRETUT(K)=NRETUT(K)-1
        NRETUF(K)=NRETUF(K)-1
175   CONTINUE
      DO 200,K=1,I6-1
        NSOLVE(K)=NSOLVE(K)-1
200   CONTINUE
      DO 225,K=1,I4-1
        NTYPE(K)=NTYPE(K)-1
225   CONTINUE
      DO 250,K=1,I1-1
        NAPERT(K)=NAPERT(K)-1
250   CONTINUE
      RETURN
      END


C$Procedure      CKR01 ( C-kernel, read pointing record, data type 1 )

      SUBROUTINE CKR01 ( HANDLE, DESCR, SCLKDP, TOL, NEEDAV,
     .                   RECORD, FOUND                       )
      IMPLICIT NONE

C$ Abstract
C
C     Read a pointing record from a CK segment, data type 1.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     CK
C     DAF
C
C$ Keywords
C
C     POINTING
C
C$ Declarations

      INTEGER               HANDLE
      DOUBLE PRECISION      DESCR  ( * )
      DOUBLE PRECISION      SCLKDP
      DOUBLE PRECISION      TOL
      LOGICAL               NEEDAV
      DOUBLE PRECISION      RECORD ( * )
      LOGICAL               FOUND

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     HANDLE     I   File handle.
C     DESCR      I   Segment descriptor.
C     SCLKDP     I   Spacecraft clock time.
C     TOL        I   Time tolerance.
C     NEEDAV     I   True when angular velocity data is requested.
C     RECORD     O   Pointing data record.
C     FOUND      O   True when data is found.
C
C$ Detailed_Input
C
C     HANDLE     is the integer handle of the CK file containing the
C                segment.
C
C     DESCR      is the descriptor of the segment.
C
C     SCLKDP     is an encoded spacecraft clock time for which
C                pointing is being requested.  The SPICELIB routines
C                SCENCD and SCDECD are used to encode and decode SCLK
C                times.
C
C     TOL        is a time tolerance, measured in the same units as
C                encoded spacecraft clock.
C
C                The record returned by CKR01 is the one whose time is
C                closest to SCLKDP and within TOL units of SCLKDP.
C
C     NEEDAV     is true when angular velocity data is requested.
C
C
C$ Detailed_Output
C
C     RECORD     is the pointing record.  Contents are as follows:
C
C                   RECORD( 1 ) = CLKOUT
C
C                   RECORD( 2 ) = q0
C                   RECORD( 3 ) = q1
C                   RECORD( 4 ) = q2
C                   RECORD( 5 ) = q3
C
C                   RECORD( 6 ) = Av1  ]
C                   RECORD( 7 ) = Av2  |-- Returned optionally
C                   RECORD( 8 ) = Av3  ]
C
C                CLKOUT is the encoded spacecraft clock time for the
C                returned pointing values. CLKOUT will be the closest
C                time in the segment to the input time as long as it is
C                within the input tolerance (see FOUND below). If SCLKDP
C                falls at the exact midpoint of two times, the record
C                for the greater of the two will be returned.
C
C                The quantities q0 - q3 represent a quaternion.
C                The quantities Av1, Av2, and Av3 represent the angular
C                velocity vector, and are returned if the segment
C                contains angular velocity data and NEEDAV is true.
C                The components of the angular velocity vector are
C                specified relative to the inertial reference frame
C                for the segment.
C
C     FOUND      is true if a record was found to satisfy the pointing
C                request. FOUND will be false when there is no pointing
C                instance within the segment whose time falls within
C                the requested time tolerance on either side of the
C                input time.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1)  If the specified handle does not belong to any file that is
C         currently known to be open, an error is diagnosed by a
C         routine that this routine calls.
C
C     2)  If DESCR is not a valid, packed descriptor of a segment in
C         the CK file specified by HANDLE, the results of this routine
C         are unpredictable.
C
C     3)  If the segment is not of data type 1, as specified in the
C         third integer component of the segment descriptor, then
C         the error SPICE(WRONGDATATYPE) is signalled.
C
C     4)  If there is a need for angular velocity data and the segment
C         contains no such data, the error SPICE(NOAVDATA) is signalled.
C
C$ Files
C
C     The file containing the segment is specified by its handle, and
C     should be opened for read, either by CKLPF or DAFOPR.
C
C$ Particulars
C
C     See the CK Required Reading file for a detailed description of
C     the structure of a type 1 pointing segment.
C
C     This routine searches a type 1 segment for the pointing instance
C     whose associated time is closest to the time that pointing was
C     requested for. If this time is within the tolerance specified by
C     the user, it sets FOUND equal to true and returns information in
C     the array RECORD that CKE01 uses to evaluate the pointing at the
C     time CLKOUT.
C
C$ Examples
C
C     The CKRnn routines are usually used in tandem with the CKEnn
C     routines, which evaluate the record returned by CKRnn to give
C     the pointing information and output time.
C
C     The following code fragment searches through a file (represented
C     by HANDLE) for all segments applicable to the Voyager 2 wide angle
C     camera, for a particular spacecraft clock time, which have data
C     type 1.  It then evaluates the pointing for that epoch and prints
C     the result.
C
C     C
C     C     - Get the spacecraft clock time. Must encode it for use
C     C       in the C-kernel.
C     C
C     C     - Set the time tolerance high to catch anything close to
C     C       the input time.
C     C
C     C     - We don't need angular velocity data.
C     C
C           SC     = -32
C           INST   = -32002
C           TOL    =  1000.D0
C           NEEDAV = .FALSE.
C           DTYPE  =  1
C     C
C     C     Load the Voyager 2 spacecraft clock kernel and the C-kernel.
C     C
C           CALL FURNSH ( 'VGR_SCLK.TSC'        )
C           CALL DAFOPR ( 'VGR2_CK.BC',  HANDLE )
C     C
C     C     Convert the input request time to ticks.
C     C
C           WRITE (*,*) 'Enter spacecraft clock time string:'
C           READ (*,FMT='(A)') SCLKCH
C           CALL SCENCD ( SC, SCLKCH, SCLKDP )
C
C     C
C     C     Search from the beginning through all segments.
C     C
C           CALL DAFBFS ( HANDLE )
C           CALL DAFFNA ( SFND   )
C
C           DO WHILE ( SFND )
C
C              CALL DAFGN ( IDENT                 )
C              CALL DAFGS ( DESCR                 )
C              CALL DAFUS ( DESCR, 2, 6, DCD, ICD )
C
C              IF ( INST          .EQ. ICD( 1 )  .AND.
C          .        DTYPE         .EQ. ICD( 3 )  .AND.
C          .        SCLKDP + TOL  .GE. DCD( 1 )  .AND.
C          .        SCLKDP - TOL  .LE. DCD( 2 ) ) THEN
C
C                 CALL CKR01 ( HANDLE, DESCR, SCLKDP, TOL, NEEDAV,
C          .                   RECORD, FOUND )
C
C                 IF ( FOUND ) THEN
C
C                    CALL CKE01 ( NEEDAV, RECORD, CMAT, AV, CLKOUT )
C
C                    WRITE (*,*) 'Segment descriptor and identifier:'
C                    WRITE (*,*) DCD, ICD
C                    WRITE (*,*) IDENT
C
C                    WRITE (*,*) 'C-matrix:'
C                    WRITE (*,*) CMAT
C
C                 END IF
C
C              END IF
C
C              CALL DAFFNA ( SFND )
C
C           END DO
C
C$ Restrictions
C
C     1) The file containing the segment should be opened for read,
C        either by CKLPF or DAFOPR.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     J.M. Lynch     (JPL)
C     J.E. McLean    (JPL)
C     M.J. Spencer   (JPL)
C     R.E. Thurman   (JPL)
C     I.M. Underwood (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.2.1, 22-AUG-2006 (EDW)
C
C        Replaced references to LDPOOL with references
C        to FURNSH.
C
C-    SPICELIB Version 1.2.0, 07-SEP-2001 (EDW)
C
C        Replaced DAFRDA call with DAFGDA.
C        Added IMPLICIT NONE.
C
C-    SPICELIB Version 1.1.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.1.0, 30-AUG-1991 (JML)
C
C        This routine now checks the segment descriptor to
C        determine if it has been given a type 1 segment.
C
C        The FOUND flag is set to FALSE at the beginning of
C        the routine.
C
C        The particulars section was changed to provide a more
C        general description of the function of this routine. The
C        information that was originally in Particulars was moved
C        to the body of the code.
C
C        The example program was changed so that the tolerance
C        and data type are used in selecting which segments to read.
C
C-    SPICELIB Version 1.0.1, 02-NOV-1990 (JML)
C
C        The example program was corrected so that the input
C        instrument code was tested against ICD(1) instead of
C        ICD(3).
C
C-    SPICELIB Version 1.0.0, 07-SEP-1990 (RET) (IMU)
C
C-&

C$ Index_Entries
C
C     read ck type_1 pointing data record
C
C-&

C$ Revisions
C
C-    SPICELIB Version 2.0.0, 30-AUG-1991 (JML)
C
C        1) This routine now checks the segment descriptor, ICD(3),
C           to determine if it has been given a type 1 segment.
C
C        2) The FOUND flag is set to FALSE at the beginning of
C           the routine.  This is done so that if a SPICE error
C           is signalled, the FOUND flag will definitely be false.
C
C        3) The particulars section was changed to provide a more
C           general description of the function of this routine. The
C           information that was originally in Particulars was moved
C           to the body of the code.
C
C        4) The example program was changed so that the tolerance
C           and data type are used in selecting which segments to read.
C
C-    SPICELIB Version 1.0.1, 02-NOV-1990 (JML)
C
C        1) The example program was corrected so that the input
C           instrument code was tested against ICD(1) instead of
C           ICD(3).
C        2) ROTATIONS was removed from the Required Reading section.
C
C-    Beta Version 1.1.0, 29-AUG-1990 (MJS) (JEM)
C
C        The following changes were made as a result of the
C        NAIF CK Code and Documentation Review:
C
C        1) The variable SCLK was changed to SCLKDP.
C        2) The declarations for the parameters QSIZ, QAVSIZ, NDC, and
C           NIC were moved from the "Declarations" section of the
C           header to the "Local parameters" section of the code below
C           the header. These parameters are not meant to modified by
C           users.
C        3) The variable DIRSIZ has been parameterized in the code
C           following the header. DIRSIZ is still 100.
C        5) The header was improved and updated to reflect the changes.
C        6) The in-code comments were improved.
C
C-    Beta Version 1.0.0, 17-MAY-1990 (RET) (IMU)
C
C-&

C
C     SPICELIB functions
C
      LOGICAL               RETURN
      INTEGER               LSTLED
      INTEGER               LSTCLD

C
C     Local parameters
C
C        DIRSIZ     is the directory size.
C
C        NDC        is the number of double precision components in an
C                   unpacked C-kernel segment descriptor.
C
C        NIC        is the number of integer components in an unpacked
C                   C-kernel segment descriptor.
C
C        QSIZ       is the number of double precision numbers making up
C                   the quaternion portion of a pointing record.
C
C        QAVSIZ     is the number of double precision numbers making up
C                   the quaternion and angular velocity portion of a
C                   pointing record.
C
C        DTYPE      is the data type of the segment that this routine
C                   operates on.
C

      INTEGER               DIRSIZ
      PARAMETER           ( DIRSIZ = 100 )

      INTEGER               NDC
      PARAMETER           ( NDC    = 2 )

      INTEGER               NIC
      PARAMETER           ( NIC    = 6 )

      INTEGER               QSIZ
      PARAMETER           ( QSIZ   = 4 )

      INTEGER               QAVSIZ
      PARAMETER           ( QAVSIZ = 7 )

      INTEGER               DTYPE
      PARAMETER           ( DTYPE =  1 )

C
C     Local variables
C
      INTEGER               ICD    ( NIC )
      INTEGER               BEG
      INTEGER               END
      INTEGER               NREC
      INTEGER               NDIR
      INTEGER               PSIZ
      INTEGER               GROUP
      INTEGER               DIRLOC
      INTEGER               REMAIN
      INTEGER               SKIP
      INTEGER               GRPNDX
      INTEGER               I
      INTEGER               N

      DOUBLE PRECISION      DCD    ( NDC )
      DOUBLE PRECISION      BUFFER ( DIRSIZ )

      LOGICAL               FND

C
C     Standard SPICE error handling.
C
      IF ( RETURN () ) THEN
         RETURN
      ELSE
         CALL CHKIN ( 'CKR01' )
      END IF

C
C     To minimize the number of file reads performed during the search,
C     a buffer of 100 double precision numbers is used to read the SCLK
C     times from the C-kernel.  If there are 10,001 or fewer pointing
C     records, at most four reads will be needed to satisfy the request:
C     one to read NREC, one to read in 100 or fewer directory times,
C     one to read 100 or fewer actual times, and then after the
C     appropriate record has been located, one to read the quaternion
C     and angular velocity data.
C
C     One more read would be required for every other group of 10,000
C     records in the segment.
C

C
C     Start off with FOUND set to FALSE.
C
      FOUND = .FALSE.
C
C     We need to look at a few of the descriptor components.
C
C     The unpacked descriptor contains the following information
C     about the segment:
C
C        DCD(1)  Initial encoded SCLK
C        DCD(2)  Final encoded SCLK
C        ICD(1)  Instrument
C        ICD(2)  Inertial reference frame
C        ICD(3)  Data type
C        ICD(4)  Angular velocity flag
C        ICD(5)  Initial address of segment data
C        ICD(6)  Final address of segment data
C
      CALL DAFUS ( DESCR, NDC, NIC, DCD, ICD )
C
C     Check to make sure that the segment is type 1.
C
      IF ( ICD( 3 ) .NE. DTYPE ) THEN

         CALL SETMSG ( 'The segment is not a type 1 segment.  ' //
     .                 'Type is #'                                 )
         CALL ERRINT ( '#', ICD(3)                                 )
         CALL SIGERR ( 'SPICE(WRONGDATATYPE)'                      )
         CALL CHKOUT ( 'CKR01'                                     )
         RETURN

      END IF

C
C     The size of the record returned depends on whether or not the
C     segment contains angular velocity data.
C
C     This is a convenient place to check if the need for angular
C     velocity data matches the availability.
C
      IF ( ICD( 4 ) .EQ. 1 ) THEN

         PSIZ = QAVSIZ

      ELSE

         PSIZ = QSIZ

         IF ( NEEDAV ) THEN

            CALL SETMSG ( 'Segment does not contain angular velocity '//
     .                    'data.'           )
            CALL SIGERR ( 'SPICE(NOAVDATA)' )
            CALL CHKOUT ( 'CKR01'           )
            RETURN

         END IF

      END IF

C
C     The beginning and ending addresses of the segment are in the
C     descriptor.
C
      BEG = ICD( 5 )
      END = ICD( 6 )

C
C     Get the number of records in this segment, and from that determine
C     the number of directory epochs.
C
      CALL DAFGDA ( HANDLE, END, END, BUFFER )
      NREC = INT( BUFFER(1) )
      NDIR = ( NREC - 1 )/DIRSIZ

C
C     The directory epochs narrow down the search to a group of DIRSIZ
C     or fewer records. The way the directory is constructed guarantees
C     that we will definitely find the closest time in the segment to
C     SCLKDP in the indicated group.
C
C     There is only one group if there are no directory epochs.
C
      IF ( NDIR .EQ. 0 ) THEN
         GROUP = 1

      ELSE
C
C        Compute the location of the first directory epoch.  From the
C        beginning of the segment, need to go through all of the
C        pointing numbers (PSIZ*NREC of them), then through all of
C        the SCLKDP times (NREC more) to get to the first SCLK
C        directory.
C
         DIRLOC = BEG + ( PSIZ + 1 ) * NREC

C
C        Locate the first directory epoch greater than SCLKDP. Read in
C        as many as DIRSIZ directory epochs at a time for comparison.
C
         FND    = .FALSE.
         REMAIN =  NDIR
         GROUP  =  0

         DO WHILE ( .NOT. FND )
C
C           The number of records to read in the buffer.
C
            N = MIN( REMAIN, DIRSIZ )

            CALL DAFGDA ( HANDLE, DIRLOC, DIRLOC + N - 1, BUFFER )

            REMAIN = REMAIN - N

C
C           If we find the first directory time greater than or equal
C           to the epoch, we're done.
C
C           If we reach the end of the directories, and still haven't
C           found one bigger than the epoch, the group is the last group
C           in the segment.
C
C           Otherwise keep looking.
C
            I = LSTLED( SCLKDP, N, BUFFER )

            IF ( I .LT. N ) THEN
               GROUP =  GROUP + I + 1
               FND   = .TRUE.

            ELSE IF ( REMAIN .EQ. 0 ) THEN
               GROUP =  NDIR + 1
               FND   = .TRUE.

            ELSE
               DIRLOC = DIRLOC + N
               GROUP  = GROUP  + N

            END IF

         END DO

      END IF

C
C     Now we know which group of DIRSIZ (or less) times to look at.
C     Out of the NREC SCLKDP times, the number that we should skip over
C     to get to the proper group is DIRSIZ*( GROUP - 1 ).
C
      SKIP = DIRSIZ*( GROUP - 1 )

C
C     From this we can compute the index into the segment of the group
C     of times we want.  From the beginning, need to pass through
C     PSIZ*NREC pointing numbers to get to the first SCLKDP time.
C     Then we skip over the number just computed above.
C
      GRPNDX = BEG + (NREC * PSIZ) + SKIP

C
C     The number of times that we have to look at may be less than
C     DIRSIZ.  However many there are, go ahead and read them into the
C     buffer.
C
      N = MIN( DIRSIZ, NREC - SKIP )

      CALL DAFGDA ( HANDLE, GRPNDX, GRPNDX + N - 1, BUFFER )

C
C     Find the time in the group closest to the input time, and see
C     if it's within tolerance.
C
      I = LSTCLD( SCLKDP, N, BUFFER )

      IF ( ABS( SCLKDP - BUFFER( I ) ) .GT. TOL ) THEN

         CALL CHKOUT ( 'CKR01' )
         RETURN

      END IF

C
C     Now we know the exact record that we want.
C
C     RECORD( 1 ) holds CLKOUT.
C
      FOUND       = .TRUE.
      RECORD( 1 ) =  BUFFER( I )

C
C     We need the Ith pointing record out of this group of DIRSIZ.
C     This group of DIRSIZ is SKIP records into the beginning
C     of the segment. And each record is PSIZ big.
C
      N = BEG + PSIZ*( SKIP + I - 1 )

      CALL DAFGDA ( HANDLE, N, N + PSIZ - 1, RECORD( 2 ) )

C
C     That is all.
C
      CALL CHKOUT ( 'CKR01' )
      RETURN
      END