!-----------------------------------------------------------------------
! transforms RICH geometry from ARTE tables to more suitable form
! M. Staric, R. Pestotnik, jul-2000, feb-2002
!
! gives photon detector in real position
! to make it in virtual position call TO_VIRT_POS after loading db
!
! SUBROUTINE LOAD_ARTE_DB(OK) - this does all, OK=.true. on success
! SUBROUTINE DB_READ_REFIND(IER)
! SUBROUTINE DB_READ_WIREMAP(MTIP,RESET,OK)
! SUBROUTINE DB_READ_ASD2FED(N_ASD,N_FED,OK)
! SUBROUTINE DB_READ_DETECTOR(OK)
! SUBROUTINE DB_READ_SUPMOD(IR,SM_DEF)
! SUBROUTINE DB_READ_DET_WINDOW(OK)
! SUBROUTINE DB_READ_DETWIN(IR,K0,DW_DEF)
! SUBROUTINE DB_READ_VESSEL(OK)
! SUBROUTINE DB_READ_BEAMSHR(RCP,DP,RP,RCE,DE,RE,OK)
! SUBROUTINE DB_READ_PLANE_MIRROR(OK)
! SUBROUTINE DB_READ_SINGLE_PLM(IR,PLM_DEF)
! SUBROUTINE DB_READ_SPHER_MIRR(OK)
! SUBROUTINE DB_READ_SINGLE_SFM(IR,SF_DEF)                                  
!-----------------------------------------------------------------------


      SUBROUTINE LOAD_ARTE_DB(OK)

      IMPLICIT NONE
      LOGICAL OK                ! .TRUE. for sucsess

#include "riter/RIC_PAR.fi"
#include "riter/RIC_WMP.fi"
#include "riter/RIC_FED.fi"
#include "riter/RIC_DETW.fi"
#include "riter/RIC_SUPM.fi"
#include "riter/RIC_VES.fi"
#include "riter/RIC_PLM.fi"
#include "riter/RIC_SFM.fi"
#include "arte/Arte.fi"
#include "auto/RITH.fi"

      LOGICAL OK1
      INTEGER N_FED, N_ASD
      INTEGER I,K,II,IO,IER
      CHARACTER*80 TXT

#include "arte/Arte.ff"
#include "auto/RITH.ff"


      CALL MEALLP
     &     ('RITER: Loading mappings and geometry from ARTE tables...')

! refractive index

      CALL MEALLP('-- Refractive index')
      CALL DB_READ_REFIND(IER)
      IF(IER.EQ.0) THEN
         CALL MEALLP('  --> From RITH')
      ELSE IF(IER.EQ.1) THEN
         CALL MEALLP('  Error in RITH --> default taken')
      ELSE IF(IER.EQ.2) THEN
         CALL MEALLP('  RITH empty --> default taken')
      ELSE
         CALL MEALLP('  Unknown error')
      ENDIF
      WRITE(TXT,*,IOSTAT=IO) '   REFIND=',REF_IND
      CALL MEALLP(TXT)

! wiring of baseboards

      CALL MEALLP('-- Wiring of baseboards')
      CALL DB_READ_WIREMAP(0,.TRUE.,OK)
      IF(.NOT.OK) RETURN

      CALL DB_READ_WIREMAP(1,.FALSE.,OK)
      IF(.NOT.OK) RETURN

      DO I=0,79
         OK1=PMT_CHAN(1,I).NE.-1
         OK=OK.AND.OK1
cc         IF(.NOT.OK1) PRINT*,'(I,PMT,CHA)',I,PMT_CHAN(1,I),PMT_CHAN(2,I)
      ENDDO
      IF(.NOT.OK) THEN
         CALL MEALLP('... Missing ASD->PMT connections')
         RETURN
      ENDIF
      DO I=0,63
         OK1=ASD_BIT(1,I).NE.-1
         OK=OK.AND.OK1
cc         IF(.NOT.OK1) PRINT*,'(I,ASD,BIT)',I,ASD_BIT(1,I),ASD_BIT(2,I)
      ENDDO
      IF(.NOT.OK) THEN
         CALL MEALLP('... Missing PMT->ASD connections (M16)')
         RETURN
      ENDIF
      DO K=0,3
         DO II=0,3
            I=64+K*16+II
            OK1=ASD_BIT(1,I).NE.-1
            OK=OK.AND.OK1
cc            IF(.NOT.OK1)PRINT*,'(I,ASD,BIT)',I,ASD_BIT(1,I),ASD_BIT(2,I)
         ENDDO
      ENDDO
      IF(.NOT.OK) THEN
         CALL MEALLP('... Missing PMT->ASD connections (M4)')
         RETURN
      ENDIF

! FED connections 

      CALL MEALLP('-- FED connections')
      CALL DB_READ_ASD2FED(N_ASD,N_FED,OK) 
      WRITE(TXT,*,IOSTAT=IO) '   Number of connected ASD: ',N_ASD,N_FED
      CALL MEALLP(TXT)
      IF(.NOT.OK) RETURN
      CALL SET_CHANNEL_MASK
      CALL SET_CHANNELS

! photon detector geometry

      CALL MEALLP('-- photon detector geometry')
      CALL DB_READ_DETECTOR(OK)
      IF(.NOT.OK) RETURN

! photon detector entry window

      CALL MEALLP('-- photon detector entry window')
      CALL DB_READ_DET_WINDOW(OK)
      IF(.NOT.OK) RETURN

! vessel

      CALL MEALLP('-- vessel')
      CALL DB_READ_VESSEL(OK)
      IF(.NOT.OK) RETURN

! plane mirror

      CALL MEALLP('-- plane mirror')
      CALL DB_READ_PLANE_MIRROR(OK)
      IF(.NOT.OK) RETURN

! spherical mirror

      CALL MEALLP('-- spherical mirror')
      CALL DB_READ_SPHER_MIRR(OK)
      IF(.NOT.OK) RETURN

! done

      IF(N_ASD.NE.N_FED.OR.N_ASD.EQ.0) THEN
         WRITE(TXT,*,IOSTAT=IO) 
     &        'Warning - number of connections: ASD side=',N_ASD,
     &        ' FED side =',N_FED
         CALL MEALLP(TXT)
      ENDIF
      RETURN
      END



      SUBROUTINE DB_READ_REFIND(IER)

      IMPLICIT NONE
      INTEGER IER
#include "riter/RIC_PAR.fi"
#include "arte/Arte.fi"
#include "auto/RITH.fi"

      REAL RADIUS
#include "arte/Arte.ff"
#include "auto/RITH.ff"

      REF_IND=REFINDEF
      IF(NRITH().GT.0) THEN
         RADIUS = FRITH_RAD0(1)*0.995
         IF(RADIUS.GT.0.AND.RADIUS.LT.(70.E-3)) THEN
            REF_IND = 1/COS(RADIUS) 
            IER=0
         ELSE
            IER=1
         ENDIF
      ELSE
         IER=2
      ENDIF            

      RETURN
      END


      SUBROUTINE DB_READ_WIREMAP(MTIP,RESET,OK)

      IMPLICIT NONE

      INTEGER MTIP              ! 0=M16, 1=M4
      LOGICAL RESET             ! T=set tables to -1
      LOGICAL OK                ! .TRUE. if all data present

#include "riter/RIC_WMP.fi"

      LOGICAL DATAERR
      INTEGER I,K,N_CH,N_PMT
      INTEGER IASD,IBIT,IPMT,ICHA, LINE,IO
      CHARACTER*80 TXT

      OK=.FALSE.
      IF(ABS(MTIP).GT.1) RETURN
      IF(RESET) THEN
         DO K=0,79
            DO I=0,1
               PMT_CHAN(I,K)=-1
            ENDDO
         ENDDO
         DO K=0,127
            DO I=0,1
               ASD_BIT(I,K)=-1
            ENDDO
         ENDDO
      ENDIF

      IF(MTIP.EQ.0) THEN
         N_CH  = 16
      ELSE
         N_CH  = 4
      ENDIF
      N_PMT = 4

      DO IPMT=0, N_PMT - 1
         DO ICHA = 0, N_CH -1
            LINE = IPMT*N_CH+ICHA 
            IF(MTIP.EQ.0) THEN
               CALL M16BASE( IPMT,ICHA,IASD,IBIT ,IO )
               IF(IO.NE.0) GOTO 1
               IF(DATAERR(IPMT,0,3,LINE,'PMT')) RETURN
               IF(DATAERR(ICHA,0,15,LINE,'PMT-CH')) RETURN
               IF(DATAERR(IASD,0,3,LINE,'ASD')) RETURN
               IF(DATAERR(IBIT,0,15,LINE,'ASD-CH')) RETURN
            ELSE 
               CALL M4BASE( IPMT,ICHA,IBIT ,IO )
               IF(IO.NE.0) GOTO 1
               IASD=4
               IF(DATAERR(IPMT,0,3,LINE,'PMT')) RETURN
               IF(DATAERR(ICHA,0,3,LINE,'PMT-CH')) RETURN
               IF(DATAERR(IBIT,0,15,LINE,'ASD-CH')) RETURN
            ENDIF

            I=IASD*16+IBIT
            IF(PMT_CHAN(1,I).EQ.-1) THEN
               PMT_CHAN(1,I)=IPMT
               PMT_CHAN(2,I)=ICHA
            ELSE
               WRITE(TXT,*,IOSTAT=IO) 
     &              'line ',LINE,': channel already connected'
               CALL MEALLP(TXT)
            ENDIF

            I=MTIP*64+IPMT*16+ICHA
            IF(ASD_BIT(1,I).EQ.-1) THEN
               ASD_BIT(1,I)=IASD
               ASD_BIT(2,I)=IBIT
            ELSE
               WRITE(TXT,*,IOSTAT=IO) 
     &              'line ',LINE,': channel already connected'
               CALL MEALLP(TXT)
            ENDIF
            
 1          CONTINUE
         ENDDO
      ENDDO
      OK=.TRUE.

      RETURN
      END




      SUBROUTINE DB_READ_ASD2FED(N_ASD,N_FED,OK)

! the definition of ROW and COL changed: both run in positive direction
! of x and y also for lower supermodules

      IMPLICIT NONE
      INTEGER N_ASD, N_FED
      LOGICAL OK

#include "riter/RIC_FED.fi"

      INTEGER K,I,II,LINE, IW, IPMT_TYPE

      LOGICAL IN_LIMITS, DATAERR
      INTEGER IASD,IPMT,IMDB,IDTB,ISM,IROW,ICOL,ICON,MM
      INTEGER IERR,J,N_CHA
      INTEGER NRICHDAQ

! reset
      N_FED=0
      DO K=0,2047
         DO I=1,4
            SM_ASD(I,K)=-1      ! this means FED Ch. not connected
         ENDDO
      ENDDO
      DO K=0,13
         DO J=0,5
            DO I=0,15
               PMTYPE(I,J,K)=-1 ! means empty baseboards
            ENDDO
         ENDDO
      ENDDO
      N_ASD=0
      DO K=0,6719
         DO I=1,2
            MDB_IW(I,K)=-1      ! means ASD not connected
         ENDDO
      ENDDO
! get number of channels
      N_CHA = NRICHDAQ()
      OK = N_CHA.GT.0
      IF ( .NOT.OK ) THEN
         CALL MEALLP('RICHDAQ not filled')
         RETURN
      ENDIF
! get map
      DO LINE=0, N_CHA-1
         CALL RICHDAQ(LINE, MM,IASD,ISM,IROW,ICOL,IMDB,IDTB,ICON, IERR )
         IF (IERR.NE.0) GOTO 1
         IF(DATAERR(IASD,0,3,LINE,'ASD ')) GOTO 1
         IF(DATAERR(ISM,0,13,LINE,'SM ')) GOTO 1
         IF(DATAERR(IROW,0,15,LINE,'ROW ')) GOTO 1
         IF(DATAERR(ICOL,0,5,LINE,'COL ')) GOTO 1
         IF(DATAERR(IMDB,0,31,LINE,'MDB ')) GOTO 1
         IF(DATAERR(IDTB,0,3,LINE,'DTB ')) GOTO 1
         IF(DATAERR(ICON,0,15,LINE,'CON ')) GOTO 1
         IF(MM.EQ.16) THEN
            IPMT_TYPE=0
         ELSE IF(MM.EQ.4) THEN
            IASD=4
            IPMT_TYPE=1
         ELSE
cc            PRINT*,'line ',LINE,': unknown PMtype'
            GOTO 1
         ENDIF
         IF(ISM.GT.6) THEN      ! change co-ordinate system for lower detector
            IROW=15-IROW
            ICOL=5-ICOL
            ISM=20-ISM
         ENDIF
         IW=IDTB*16+ICON
         I=IMDB*64+IW
         II=((ISM*6+ICOL)*16+IROW)*5+IASD
         IF(SM_ASD(1,I).EQ.-1) THEN
            SM_ASD(1,I)=ISM
            SM_ASD(2,I)=ICOL
            SM_ASD(3,I)=IROW
            SM_ASD(4,I)=IASD
            N_FED=N_FED+1
            MDB_IW(1,II)=IMDB
            MDB_IW(2,II)=IW
            N_ASD=N_ASD+1
         ENDIF
         PMTYPE(IROW,ICOL,ISM)=IPMT_TYPE
 1       CONTINUE
      ENDDO

      RETURN
      END



      SUBROUTINE DB_READ_DETECTOR(OK)

! the definition of supermodule coordinate system changed: now also for
! lower supermodules the origin is in lower-left corner
! lower supermodules: indexes changed !!
!
!  0  1  2  3  4  5  6
!  7  8  9 10 11 12 13
!

      IMPLICIT NONE
      LOGICAL OK

#include "riter/RIC_SUPM.fi"
#include "arte/Arte.fi"
#include "auto/CSUP.fi"

      LOGICAL SM_DEF(0:13)
      INTEGER IR, K,I,IO
      CHARACTER*80 TXT

#include "arte/Arte.ff"
#include "auto/CSUP.ff"

      DO I=0,13
         SM_DEF(I)=.FALSE.
      ENDDO
      DO IR=1, NCSUP()
         CALL DB_READ_SUPMOD(IR,SM_DEF)
      ENDDO

      OK=.TRUE.
      DO K=0,13
         IF(.NOT.SM_DEF(K)) THEN
            OK=.FALSE.
            WRITE(TXT,*,IOSTAT=IO) 'SuperModule #',K,' not defined'
            CALL MEALLP(TXT)
         ENDIF
      ENDDO
      IF(.NOT.OK) RETURN
      CALL SM_TO_REAL_POS

      RETURN
      END



      SUBROUTINE DB_READ_SUPMOD(IR,SM_DEF)

! the definition of supermodule coordinate system changed: now also for
! lower supermodules the origin is in lower-left corner
! lower supermodules: indexes changed !!
!
!  0  1  2  3  4  5  6
!  7  8  9 10 11 12 13
!

      IMPLICIT NONE

      INTEGER IR
      LOGICAL SM_DEF(0:13)

#include "riter/RIC_SUPM.fi"
#include "arte/Arte.fi"
#include "auto/CSUP.fi"

      INTEGER ID,I
      REAL ORIGIN(3), X_VECTOR(3), Y_VECTOR(3)
      LOGICAL DATAERR

#include "arte/Arte.ff"
#include "auto/CSUP.ff"

      ID = ICSUP_ID(IR) 
      IF(DATAERR(ID,0,13,IR,'SupModID')) RETURN
      
      ORIGIN(1) = FCSUP_X0(1,IR) 
      ORIGIN(2) = FCSUP_X0(2,IR) 
      ORIGIN(3) = FCSUP_X0(3,IR) 

      X_VECTOR(1) = FCSUP_XVEC(1,IR) 
      X_VECTOR(2) = FCSUP_XVEC(2,IR) 
      X_VECTOR(3) = FCSUP_XVEC(3,IR) 

      Y_VECTOR(1) = FCSUP_YVEC(1,IR) 
      Y_VECTOR(2) = FCSUP_YVEC(2,IR) 
      Y_VECTOR(3) = FCSUP_YVEC(3,IR) 

      IF(ID.GT.6) ID=20-ID
      SM_DEF(ID)=.TRUE.
      IF(ID.LT.7) THEN
         DO I=1,3
            SM_ORIG(I,ID)=ORIGIN(I)
            SM_X_VEC(I,ID)=X_VECTOR(I)
            SM_Y_VEC(I,ID)=Y_VECTOR(I)
         ENDDO
      ELSE
         DO I=1,3
            SM_ORIG(I,ID)=ORIGIN(I)+X_VECTOR(I)+Y_VECTOR(I)
            SM_X_VEC(I,ID)=-X_VECTOR(I)
            SM_Y_VEC(I,ID)=-Y_VECTOR(I)
         ENDDO
      ENDIF

      RETURN
      END



      SUBROUTINE DB_READ_DET_WINDOW(OK)

      IMPLICIT NONE
      LOGICAL OK

#include "riter/RIC_DETW.fi"
#include "arte/Arte.fi"
#include "auto/CPDW.fi"

      INTEGER IR
      REAL YORIG
      INTEGER I,K,IO
      LOGICAL DW_DEF(0:1)
      CHARACTER*80 TXT

#include "arte/Arte.ff"
#include "auto/CPDW.ff"

      DO I=0,1
         DW_DEF(I)=.FALSE.
      ENDDO

      DO I=1,NCPDW()
         YORIG = FCPDW_ORIG(2,I)
         IF ( YORIG .GT. 0 ) THEN
            K=0
            CALL DB_READ_DETWIN(I,K,DW_DEF(K))  
         ELSE
            K=1
            CALL DB_READ_DETWIN(I,K,DW_DEF(K))  
         ENDIF
      ENDDO

      OK=.TRUE.
      DO K=0,1
         IF(.NOT.DW_DEF(K)) THEN
            OK=.FALSE.
            WRITE(TXT,*,IOSTAT=IO) 
     &           'PhotonDetecotorEntryWindow #',K,' not defined'
            CALL MEALLP(TXT)
         ENDIF
      ENDDO
      IF(.NOT.OK) RETURN
      CALL DW_TO_REAL_POS

      RETURN
      END



      SUBROUTINE DB_READ_DETWIN(IR,K0,DW_DEF)

      IMPLICIT NONE

      INTEGER IR
      INTEGER K0
      LOGICAL DW_DEF

#include "riter/RIC_DETW.fi"
#include "arte/Arte.fi"
#include "auto/CPDW.fi"

      INTEGER I
      REAL ORIGIN(3), X_VECTOR(3), Y_VECTOR(3)

#include "arte/Arte.ff"
#include "auto/CPDW.ff"


      DW_THICK(K0) = FCPDW_T(IR)

      ORIGIN(1) = FCPDW_ORIG(1,IR) 
      ORIGIN(2) = FCPDW_ORIG(2,IR) 
      ORIGIN(3) = FCPDW_ORIG(3,IR) 

      X_VECTOR(1) = FCPDW_XVEC(1,IR) 
      X_VECTOR(2) = FCPDW_XVEC(2,IR) 
      X_VECTOR(3) = FCPDW_XVEC(3,IR) 

      Y_VECTOR(1) = FCPDW_YVEC(1,IR) 
      Y_VECTOR(2) = FCPDW_YVEC(2,IR) 
      Y_VECTOR(3) = FCPDW_YVEC(3,IR) 
      
      DO I=1,3
         DW_ORIG(I,K0)=ORIGIN(I)
         DW_X_VEC(I,K0)=X_VECTOR(I)
         DW_Y_VEC(I,K0)=Y_VECTOR(I)
      ENDDO

      DW_DEF = .TRUE.

      RETURN
      END



      SUBROUTINE DB_READ_VESSEL(OK)

      IMPLICIT NONE
      LOGICAL OK

#include "riter/RIC_VES.fi"
#include "riter/RIC_PLM.fi"
#include "riter/RIC_SFM.fi"

      CALL DB_READ_BEAMSHR(PBS_RC,PBS_LEN,PBS_R,EBS_RC,EBS_LEN,EBS_R,OK)
      IF(.NOT.OK) RETURN
      
      PL_HOLE_X=EBS_RC(1)
      PL_HOLE_Y=EBS_RC(2)
      SF_EHOLE_X=EBS_RC(1)
      SF_EHOLE_Y=EBS_RC(2)

ccc   beam z and length are wrong, so
      PBS_RC(3)=Z_IN
      EBS_RC(3)=Z_IN
      PBS_LEN=Z_OUT-Z_IN
      EBS_LEN=Z_OUT-Z_IN

      RETURN
      END



      SUBROUTINE DB_READ_BEAMSHR(RCP,DP,RP,RCE,DE,RE,OK)

      IMPLICIT NONE
      REAL RCP(3), DP, RP
      REAL RCE(3), DE, RE
      LOGICAL OK

#include "arte/Arte.fi"
#include "auto/CVES.fi"

      INTEGER IR

#include "arte/Arte.ff"
#include "auto/CVES.ff"

      OK = NCVES().GT.0
      IF ( .NOT.OK ) RETURN

      IR = 1

c     proton  beam shroud
c     center
      RCP(1) = FCVES_PORI(1,IR) 
      RCP(2) = FCVES_PORI(2,IR) 
      RCP(3) = FCVES_PORI(3,IR) 
         
c     axis length
      DP  = FCVES_PLEN(IR)

c     radius
      RP  = FCVES_PRAD(IR)

c     electron beam shroud
c     center
      RCE(1) = FCVES_EORI(1,IR) 
      RCE(2) = FCVES_EORI(2,IR) 
      RCE(3) = FCVES_EORI(3,IR) 
         
c     axis length
      DE  = FCVES_ELEN(IR)

c     radius
      RE  = FCVES_ERAD(IR)

      RETURN
      END



      SUBROUTINE DB_READ_PLANE_MIRROR(OK)

      IMPLICIT NONE
      LOGICAL OK

#include "riter/RIC_PLM.fi"
#include "arte/Arte.fi"
#include "auto/CSPM.fi"
#include "auto/CPMI.fi"

      INTEGER IR,I,K,KK,IO
      LOGICAL PLM_DEF(0:35)
      CHARACTER*80 TXT

#include "arte/Arte.ff"
#include "auto/CSPM.ff"
#include "auto/CPMI.ff"

      DO I=0,35
         PLM_DEF(I)=.FALSE.
      ENDDO
      DO IR =1,NCSPM()
         CALL DB_READ_SINGLE_PLM(IR,PLM_DEF)
      ENDDO

      IF(NCPMI().GT.0) THEN
         PL_HOLE_R = FCPMI_REC(1)
      ELSE
         CALL MEALLP('Table CPMI is empty: CPMI.rec=0 taken')
         PL_HOLE_R = 0
      ENDIF

      OK=.TRUE.
      DO I=0,35
         IF(.NOT.PLM_DEF(I)) THEN
            OK=.FALSE.
            WRITE(TXT,*,IOSTAT=IO) 'Plane mirror ',I,' not defined'
            CALL MEALLP(TXT)
         ENDIF
      ENDDO
      IF(.NOT.OK) RETURN

! normales and squere of lengths
      DO K=0,35
         CALL VEKT_PROD(PL_X_VEC(1,K),PL_Y_VEC(1,K),PL_NOR(1,K))
         CALL ENOTNI_VEKT(PL_NOR(1,K))
         PL_DXVEC(K)=PL_X_VEC(1,K)**2+PL_X_VEC(2,K)**2+PL_X_VEC(3,K)**2
         PL_DYVEC(K)=PL_Y_VEC(1,K)**2+PL_Y_VEC(2,K)**2+PL_Y_VEC(3,K)**2
      ENDDO
! nonsegmented mirror
      DO K=0,1
         KK=(1-K)*18
         DO I=1,3
            PL_R0(I,K)=PL_ORIG(I,KK)
            PL_VX(I,K)=PL_ORIG(I,KK+5)+PL_X_VEC(I,KK+5)-PL_ORIG(I,KK)
            PL_VY(I,K)=PL_ORIG(I,KK+12)+PL_Y_VEC(I,KK+12)-PL_ORIG(I,KK)
         ENDDO
         CALL VEKT_PROD(PL_VX(1,K),PL_VY(1,K),PL_VN(1,K))
         CALL ENOTNI_VEKT(PL_VN(1,K))
         PL_DX(K)=PL_VX(1,K)**2+PL_VX(2,K)**2+PL_VX(3,K)**2
         PL_DY(K)=PL_VY(1,K)**2+PL_VY(2,K)**2+PL_VY(3,K)**2
         PL_YMIN(K)=MIN(ABS(PL_R0(2,K)),ABS(PL_R0(2,K)+PL_VY(2,K)))
      ENDDO
      RETURN
      END


      SUBROUTINE DB_READ_SINGLE_PLM(IR,PLM_DEF)

      IMPLICIT NONE
      INTEGER IR
      LOGICAL PLM_DEF(0:35)

#include "riter/RIC_PLM.fi"
#include "arte/Arte.fi"
#include "auto/CSPM.fi"

      REAL ORIGIN(3), X_VECTOR(3), Y_VECTOR(3)
      LOGICAL DATAERR
      INTEGER IROW,ICOL,ID,I

      CHARACTER*80 CC
      CHARACTER*4 CQ(NARZEB)
      EQUIVALENCE (IQ(1),CQ(1))
#include "arte/Arte.ff"
#include "auto/CSPM.ff"


      DO I=0,NCSPM_TYPE-1
         CC(I*4+1:)=CQ( HQCSPM_TYPE(I+1,IR))
      ENDDO
      IF(INDEX(CC(1:NCSPM_TYPE*4),'PM1').EQ.0) RETURN

      IROW = ICSPM_ROW(IR)
      ICOL = ICSPM_COL(IR)

      ORIGIN(1) = FCSPM_ORIG(1,IR)
      ORIGIN(2) = FCSPM_ORIG(2,IR)
      ORIGIN(3) = FCSPM_ORIG(3,IR)

      X_VECTOR(1) = FCSPM_XVEC(1,IR)
      X_VECTOR(2) = FCSPM_XVEC(2,IR)
      X_VECTOR(3) = FCSPM_XVEC(3,IR)

      Y_VECTOR(1) = FCSPM_YVEC(1,IR)
      Y_VECTOR(2) = FCSPM_YVEC(2,IR)
      Y_VECTOR(3) = FCSPM_YVEC(3,IR)

      ID=IROW*6+ICOL
      IF(DATAERR(ID,0,35,IR,'index ')) RETURN
      DO I=1,3
         PL_ORIG(I,ID)=ORIGIN(I)
         PL_X_VEC(I,ID)=X_VECTOR(I)
         PL_Y_VEC(I,ID)=Y_VECTOR(I)
      ENDDO
      PLM_DEF(ID)=.TRUE.

      RETURN
      END



      SUBROUTINE DB_READ_SPHER_MIRR(OK)

      IMPLICIT NONE

      LOGICAL OK

#include "riter/RIC_SFM.fi"
#include "arte/Arte.fi"
#include "auto/CSSM.fi"
#include "auto/CSMI.fi"

      INTEGER I,IR,K,KK,J,IO
      REAL RRR
      LOGICAL SF_DEF(0:79)
      CHARACTER*80 TXT

#include "arte/Arte.ff"
#include "auto/CSSM.ff"
#include "auto/CSMI.ff"

      OK = NCSSM().GT.0
      IF ( .NOT.OK ) THEN
         CALL MEALLP('Table CSSM is empty')
         RETURN
      ENDIF
      DO I=0,79
         SF_DEF(I)=.FALSE.
      ENDDO
      DO IR =1,NCSSM()
         CALL DB_READ_SINGLE_SFM(IR,SF_DEF)
      ENDDO
      OK=.TRUE.
      DO I=0,79
         IF(.NOT.SF_DEF(I)) THEN
            OK=.FALSE.
            WRITE(TXT,*,IOSTAT=IO) 'Spherical mirror ',I,' not defined'
            CALL MEALLP(TXT)
         ENDIF
      ENDDO
      IF(.NOT.OK) RETURN

      OK = NCSMI().GT.0
      IF ( .NOT.OK ) THEN
         CALL MEALLP('Table CSMI is empty')
         RETURN
      ENDIF
      IR = 1
      RRR =  FCSMI_R(IR)
      R_MI(0) = RRR
      R_MI(1) = RRR
      SF_PHOLE_R =  FCSMI_RPC(IR)
      SF_EHOLE_R =  FCSMI_REC(IR)

! nonsegmented mirror
      DO K=0,1
         DO I=1,3
            RCMI(I,K)=0.
         ENDDO
         KK=(1-K)*40
         DO J=KK,KK+39
            DO I=1,3
               RCMI(I,K)=RCMI(I,K)+SF_CEN(I,J)+R_MI(K)*SF_NOR(I,J)
            ENDDO
         ENDDO
         DO I=1,3
            RCMI(I,K)=RCMI(I,K)/40.
         ENDDO
      ENDDO
      SF_TX=0.
      SF_Y=0.
      DO K=0,79
         DO I=1,SF_NVTC(K)
            SF_TX=MAX(SF_TX,ABS(SF_VTCS(1,I,K)/SF_VTCS(3,I,K)))
            SF_Y=MAX(SF_Y,ABS(SF_VTCS(2,I,K)))
         ENDDO
      ENDDO

      RETURN
      END



      SUBROUTINE DB_READ_SINGLE_SFM(IR,SF_DEF)

      IMPLICIT NONE

      INTEGER IR
      LOGICAL SF_DEF(0:79)

#include "riter/RIC_SFM.fi"
#include "arte/Arte.fi"
#include "auto/CSSM.fi"

      REAL NORMAL(3)
      INTEGER IROW,ICOL,ID
      INTEGER I,K
      LOGICAL DATAERR 
      CHARACTER*80 CC
      CHARACTER*4 CQ(NARZEB)
      EQUIVALENCE (IQ(1),CQ(1))

#include "arte/Arte.ff"
#include "auto/CSSM.ff"

      DO I=0,NCSSM_TYPE-1
         CC(I*4+1:)=CQ( HQCSSM_TYPE(I+1,IR))
      ENDDO
      IF(INDEX(CC(1:NCSSM_TYPE*4),'FULL').NE.0) RETURN

      IROW = ICSSM_ROW(IR)
      ICOL = ICSSM_COL(IR)
      ID=IROW*10+ICOL
      IF(DATAERR(ID,0,79,IR,'index ')) RETURN

      DO I=1,3
         SF_CEN(I,ID) = FCSSM_ORIG(I,IR)
         NORMAL(I) = FCSSM_NORM(I,IR)
         SF_HOR(I,ID) = FCSSM_XVEC(I,IR)
         SF_RC(I,ID)=SF_CEN(I,ID)+NORMAL(I)
      ENDDO
      SF_RMI(ID)=SQRT(NORMAL(1)**2+NORMAL(2)**2+NORMAL(3)**2)
      DO I=1,3
         SF_NOR(I,ID) = NORMAL(I)/SF_RMI(ID)
      ENDDO

      SF_NVTC(ID)=MIN(ICSSM_NCOR(IR),6)
      DO K=1,SF_NVTC(ID)
         DO I=1,3
            SF_VTCS(I,K,ID)=FCSSM_CORN(I+(K-1)*3,IR)
         ENDDO
      ENDDO
      SF_DEF(ID)=.TRUE.

      RETURN
      END



