!-----------------------------------------------------------------------
! load_util_db.F : some additional routines used by load_arte_db.F
!                  or elsewhere ...
! M. Staric, jul-2000
!
! SUBROUTINE TO_XYZ(MDB,IW,IB,R,SIG2,ITIP,OK)
! SUBROUTINE TO_VIRT_POS
! SUBROUTINE SM_TO_VIRT_POS
! SUBROUTINE DW_TO_VIRT_POS
! SUBROUTINE TO_REAL_POS
! SUBROUTINE SM_TO_REAL_POS
! SUBROUTINE DW_TO_REAL_POS
! SUBROUTINE SET_CHANNEL_MASK
! SUBROUTINE SET_CHANNELS
! SUBROUTINE BEAM_SHR_CORRECT
! LOGICAL FUNCTION DATAERR(I,IMI,IMA,LINE,MESS)
! LOGICAL FUNCTION TEST_TAG(TT,TAG)
! SUBROUTINE STRIP_OFF(TT,LENG)
! SUBROUTINE STRIP_OFF_HASH(TT,LENG)
! SUBROUTINE SUB_STRING(TT,SS,L)                                            
!-----------------------------------------------------------------------


      SUBROUTINE TO_XYZ(MDB,IW,IB,R,SIG2,ITIP,OK)

#include "riter/RIC_WMP.fi"
#include "riter/RIC_FED.fi"
#include "riter/RIC_SUPM.fi"

      INTEGER MDB               ! Motherboard ID (0:31)
      INTEGER IW                ! word count (0:63)
      INTEGER IB                ! bit (0:15)
      REAL R(3)                 ! co-ordinate of the middle of a pad
      REAL SIG2                 ! SIGMA**2 of a pad in mrad
      INTEGER ITIP              ! pm type (0=M16, 1=M4)
      LOGICAL OK                ! T if channel connected

      II=MDB*64+IW
      ISM=SM_ASD(1,II)
      OK=ISM.NE.-1
      IF(.NOT.OK) RETURN
      ICOL=SM_ASD(2,II)
      IROW=SM_ASD(3,II)
      IASD=SM_ASD(4,II)
      
      II=IASD*16+IB
      IPMT=PMT_CHAN(1,II)
      ICHA=PMT_CHAN(2,II)

      ITIP=PMTYPE(IROW,ICOL,ISM)
      IPAD=ITIP+1
      SIG2=(9./5700.*IPAD)**2/12.

      IF(ITIP.EQ.0) THEN
         A=(ICOL*2+MOD(IPMT,2))*4+3-MOD(ICHA,4)+.5
         B=(IROW*2+IPMT/2)*4+3-ICHA/4+.5
      ELSE
         A=(ICOL*2+MOD(IPMT,2))*4+(1-MOD(ICHA,2))*2+1
         B=(IROW*2+IPMT/2)*4+(1-ICHA/2)*2+1
      ENDIF
      A=A/48
      B=B/128
      DO I=1,3
         R(I)=SM_R0(I,ISM)+A*SM_VX(I,ISM)+B*SM_VY(I,ISM)
      ENDDO

      RETURN
      END


      SUBROUTINE TO_VIRT_POS

      CALL SM_TO_VIRT_POS
      CALL DW_TO_VIRT_POS

      RETURN
      END


      SUBROUTINE SM_TO_VIRT_POS

#include "riter/RIC_SUPM.fi"
#include "riter/RIC_PLM.fi"
      REAL R0(3), VX(3), VY(3)

      DO K=0,13
         KK=K/7
         DO I=1,3
            R0(I)=SM_ORIG(I,K)-PL_R0(I,KK)
            VX(I)=SM_X_VEC(I,K)
            VY(I)=SM_Y_VEC(I,K)
         ENDDO
         CALL SKAL_PROD(R0,PL_VN(1,KK),S0)
         CALL SKAL_PROD(VX,PL_VN(1,KK),SX)
         CALL SKAL_PROD(VY,PL_VN(1,KK),SY)
         DO I=1,3
            SM_R0(I,K)=SM_ORIG(I,K)-2.*S0*PL_VN(I,KK)
            SM_VX(I,K)=SM_X_VEC(I,K)-2.*SX*PL_VN(I,KK)
            SM_VY(I,K)=SM_Y_VEC(I,K)-2.*SY*PL_VN(I,KK)
         ENDDO
         CALL VEKT_PROD(SM_VX(1,K),SM_VY(1,K),SM_VN(1,K))
         CALL ENOTNI_VEKT(SM_VN(1,K))
         SM_DX(K)=SM_VX(1,K)**2+SM_VX(2,K)**2+SM_VX(3,K)**2
         SM_DY(K)=SM_VY(1,K)**2+SM_VY(2,K)**2+SM_VY(3,K)**2
      ENDDO
      SM_VIRTUAL=.TRUE.

      RETURN
      END


      SUBROUTINE DW_TO_VIRT_POS

#include "riter/RIC_DETW.fi"
#include "riter/RIC_PLM.fi"
      REAL R0(3), VX(3), VY(3)

      DO K=0,1
         KK=K/7
         DO I=1,3
            R0(I)=DW_ORIG(I,K)-PL_R0(I,KK)
            VX(I)=DW_X_VEC(I,K)
            VY(I)=DW_Y_VEC(I,K)
         ENDDO
         CALL SKAL_PROD(R0,PL_VN(1,KK),S0)
         CALL SKAL_PROD(VX,PL_VN(1,KK),SX)
         CALL SKAL_PROD(VY,PL_VN(1,KK),SY)
         DO I=1,3
            DW_R0(I,K)=DW_ORIG(I,K)-2.*S0*PL_VN(I,KK)
            DW_VX(I,K)=DW_X_VEC(I,K)-2.*SX*PL_VN(I,KK)
            DW_VY(I,K)=DW_Y_VEC(I,K)-2.*SY*PL_VN(I,KK)
         ENDDO
         CALL VEKT_PROD(DW_VX(1,K),DW_VY(1,K),DW_VN(1,K))
         CALL ENOTNI_VEKT(DW_VN(1,K))
         DW_DX(K)=DW_VX(1,K)**2+DW_VX(2,K)**2+DW_VX(3,K)**2
         DW_DY(K)=DW_VY(1,K)**2+DW_VY(2,K)**2+DW_VY(3,K)**2
      ENDDO
      DW_VIRTUAL=.TRUE.

      RETURN
      END


      SUBROUTINE TO_REAL_POS

      CALL SM_TO_REAL_POS
      CALL DW_TO_REAL_POS
      RETURN
      END


      SUBROUTINE SM_TO_REAL_POS

#include "riter/RIC_SUPM.fi"

      DO K=0,13
         DO I=1,3
            SM_R0(I,K)=SM_ORIG(I,K)
            SM_VX(I,K)=SM_X_VEC(I,K)
            SM_VY(I,K)=SM_Y_VEC(I,K)
         ENDDO
         CALL VEKT_PROD(SM_VX(1,K),SM_VY(1,K),SM_VN(1,K))
         CALL ENOTNI_VEKT(SM_VN(1,K))
         SM_DX(K)=SM_VX(1,K)**2+SM_VX(2,K)**2+SM_VX(3,K)**2
         SM_DY(K)=SM_VY(1,K)**2+SM_VY(2,K)**2+SM_VY(3,K)**2
      ENDDO
      SM_VIRTUAL=.FALSE.

      RETURN
      END


      SUBROUTINE DW_TO_REAL_POS

#include "riter/RIC_DETW.fi"

      DO K=0,1
         DO I=1,3
            DW_R0(I,K)=DW_ORIG(I,K)
            DW_VX(I,K)=DW_X_VEC(I,K)
            DW_VY(I,K)=DW_Y_VEC(I,K)
         ENDDO
         CALL VEKT_PROD(DW_VX(1,K),DW_VY(1,K),DW_VN(1,K))
         CALL ENOTNI_VEKT(DW_VN(1,K))
         DW_DX(K)=DW_VX(1,K)**2+DW_VX(2,K)**2+DW_VX(3,K)**2
         DW_DY(K)=DW_VY(1,K)**2+DW_VY(2,K)**2+DW_VY(3,K)**2
      ENDDO
      DW_VIRTUAL=.FALSE.

      RETURN
      END


      SUBROUTINE SET_CHANNEL_MASK

#include "riter/RIC_FED.fi"
#include "riter/RIC_MASK.fi"

      DO MDB=0,31
         DO IW=0,63
            I=MDB*64+IW
            IF(SM_ASD(1,I).LT.0) THEN
               MASK_CH(IW,MDB)=0
            ELSE
               MASK_CH(IW,MDB)=-1
            ENDIF
         ENDDO
      ENDDO      

      RETURN
      END


      SUBROUTINE SET_CHANNELS

#include "riter/RIC_WMP.fi"
#include "riter/RIC_FED.fi"
#include "riter/RIC_MASK.fi"
#include "riter/RIC_CHA.fi"

! reset
      DO ISM=0,13
         DO IC=0,47
            DO IR=0,127
               CH_DET(IR,IC,ISM)=-1
            ENDDO
         ENDDO
      ENDDO
      DO I=0,NCHAN-1
         CH_TIP(I)=-1
      ENDDO
! set
      DO MDB=0,31
         DO IW=0,63
            I=MDB*64+IW
            ISM=SM_ASD(1,I)
            IF(ISM.GE.0) THEN
               ICOL=SM_ASD(2,I)
               IROW=SM_ASD(3,I)
               IASD=SM_ASD(4,I)
               I0=I*16
               DO IB=0,15
                  IF(BTEST(MASK_CH(IW,MDB),IB)) THEN
                     II=IASD*16+IB
                     IPMT=PMT_CHAN(1,II)
                     ICHA=PMT_CHAN(2,II)
                     ITIP=PMTYPE(IROW,ICOL,ISM)
                     III=I0+IB
                     CH_TIP(III)=ITIP
                     IF(ITIP.EQ.0) THEN
                        IC=(ICOL*2+MOD(IPMT,2))*4+3-MOD(ICHA,4)
                        IR=(IROW*2+IPMT/2)*4+3-ICHA/4
                        CH_DET(IR,IC,ISM)=III
                     ELSE
                        IC=(ICOL*2+MOD(IPMT,2))*4+(1-MOD(ICHA,2))*2
                        IR=(IROW*2+IPMT/2)*4+(1-ICHA/2)*2
                        CH_DET(IR,IC,ISM)=III
                        CH_DET(IR+1,IC,ISM)=III
                        CH_DET(IR+1,IC+1,ISM)=III
                        CH_DET(IR,IC+1,ISM)=III
                     ENDIF
                  ENDIF
               ENDDO
            ENDIF
         ENDDO
      ENDDO      

      RETURN
      END



      SUBROUTINE BEAM_SHR_CORRECT

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

      PBS_RC(3)=Z_IN
      EBS_RC(3)=PL_VY(3,1)/PL_VY(2,1)*(EBS_RC(2)-PL_R0(2,1))+PL_R0(3,1)

      X=PBS_RC(1)-RCMI(1,1)
      Y=PBS_RC(2)-RCMI(2,1)
      Z=PBS_RC(3)-RCMI(3,1)
      D=R_MI(1)**2-X**2-Y**2
      IF(D.GE.0) PBS_LEN=SQRT(D)-Z
 
      X=EBS_RC(1)-RCMI(1,1)
      Y=EBS_RC(2)-RCMI(2,1)
      Z=EBS_RC(3)-RCMI(3,1)
      D=R_MI(1)**2-X**2-Y**2
      IF(D.GE.0) EBS_LEN=SQRT(D)-Z
 
      RETURN
      END



      LOGICAL FUNCTION DATAERR(I,IMI,IMA,LINE,MESS)

      INTEGER I, IMI, IMA
      INTEGER LINE
      CHARACTER*(*) MESS
      CHARACTER*80 TXT
     
      DATAERR=I.LT.IMI.OR.I.GT.IMA
      IF(DATAERR) THEN
         WRITE(TXT,*,IOSTAT=IO) 'line ',LINE,': ',MESS(1:LEN(MESS)),
     &        '- number out of range ',I,IMI,IMA
         CALL MEALLP(TXT)
      ENDIF

      RETURN
      END



      LOGICAL FUNCTION TEST_TAG(TT,TAG)

      CHARACTER*(*) TT, TAG

      LL=MIN(LEN(TT),LEN(TAG))
      TEST_TAG=TT(1:LL).EQ.TAG
      IF(TEST_TAG) THEN
         TT=TT(LEN(TAG)+1:)
      ENDIF

      RETURN
      END



      SUBROUTINE STRIP_OFF(TT,LENG)
      
      CHARACTER*(*) TT
      INTEGER LENG
      LOGICAL Q
      
      DO I=1,LEN(TT)
         IF(TT(I:I).EQ.CHAR(9)) TT(I:I)=' '
      ENDDO
      DO I=1,LEN(TT)
         IF(TT(1:1).EQ.' ') THEN
            TT=TT(2:LEN(TT))
         ENDIF
      ENDDO
      
      Q=.TRUE.
      LENG=0
      DO I=LEN(TT),1,-1
         IF(TT(I:I).NE.' '.AND.Q) THEN
            LENG=I
            Q=.FALSE.
         ENDIF
      ENDDO
      
      RETURN
      END



      SUBROUTINE STRIP_OFF_HASH(TT,LENG)
      
      CHARACTER*(*) TT
      INTEGER LENG
      LOGICAL Q
      
      LLL=INDEX(TT,'#')-1
      IF(LLL.LT.0) LLL=LEN(TT)
      DO I=1,LLL
         IF(TT(I:I).EQ.CHAR(9)) TT(I:I)=' '
      ENDDO
      DO I=1,LLL
         IF(TT(1:1).EQ.' ') THEN
            TT=TT(2:LLL)
         ENDIF
      ENDDO
      
      Q=.TRUE.
      LENG=0
      DO I=LLL,1,-1
         IF(TT(I:I).NE.' '.AND.Q) THEN
            LENG=I
            Q=.FALSE.
         ENDIF
      ENDDO
      
      RETURN
      END



      SUBROUTINE SUB_STRING(TT,SS,L)

! gets substring SS, shifts string TT left removing SS from it
! delimiters are SPs or TABs

      CHARACTER*(*) TT, SS      ! string, substring
      INTEGER L                 ! LEN of substring

      LT=LEN(TT)
      I=1
      DO WHILE(TT(I:I).EQ.' '.OR.TT(I:I).EQ.CHAR(9))
         I=I+1
         IF(I.GT.LT) THEN
            L=0
            SS=' '
            TT=' '
            RETURN
         ENDIF
      ENDDO
      I1=I
      DO WHILE(.NOT.(TT(I:I).EQ.' '.OR.TT(I:I).EQ.CHAR(9)))
         I=I+1
         IF(I.GT.LT) GOTO 1
      ENDDO
 1    CONTINUE
      I2=I-1
      L=I2-I1+1
      IF(L.EQ.0) THEN
         SS=' '
      ELSE
         SS=TT(I1:I2)
      ENDIF
      IF(I.GT.LT) THEN
         TT=' '
      ELSE
         TT=TT(I:LT)
      ENDIF
      RETURN
      END



