*DECK SYBCP1
      SUBROUTINE SYBCP1 (IPTRK,ITG,IMPX,NREG,SIGT,SIGW,PIJ)
*
*-----------------------------------------------------------------------
*
*Purpose:
* calculation of the scattering-reduced collision probabilities for
* Sybil.
*
*Copyright:
* Copyright (C) 2002 Ecole Polytechnique de Montreal
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
* License as published by the Free Software Foundation; either
* version 2.1 of the License, or (at your option) any later version
*
*Author(s): A. Hebert
*
*Parameters: input
* IPTRK   pointer to the Sybil tracking (L_TRACK signature).
* ITG     type of Sybil one-speed solution operator.
* IMPX    print flag (equal to zero for no print).
* NREG    total number of regions.
* SIGT    total macroscopic cross sections ordered by volume.
* SIGW    P0 within-group scattering macroscopic cross sections
*         ordered by volume.
*
*Parameters: output
* PIJ     scattering-reduced collision probabilities matrix.
*
*-----------------------------------------------------------------------
*
      USE GANLIB
*----
*  SUBROUTINE ARGUMENTS
*----
      TYPE(C_PTR) IPTRK
      INTEGER ITG,IMPX,NREG
      REAL SIGT(NREG),SIGW(NREG),PIJ(NREG,NREG)
*----
*  LOCAL VARIABLES
*----
      INTEGER IPAR(16)
      INTEGER, TARGET, SAVE, DIMENSION(1) :: IDUMMY
      REAL, TARGET, SAVE, DIMENSION(1) :: DUMMY
      INTEGER, ALLOCATABLE, DIMENSION(:) :: NCODE,NMC3,LSEC4,NMC4,NMCR4,
     1 MAIL,IFR,INUM,MIX,IGEN
      REAL, ALLOCATABLE, DIMENSION(:) :: XX2,ZCODE,ZTR,RAYR3,PROCE,XX4,
     1 YY4,RAYR4,ALB,DVX
      INTEGER, POINTER, DIMENSION(:) :: IZMAI
      REAL, POINTER, DIMENSION(:) :: RZMAI
      TYPE(C_PTR) :: IZMAI_PTR,RZMAI_PTR
*
      IF(ITG.EQ.1) THEN
         PIJ(1,1)=1.0/(SIGT(1)-SIGW(1))
      ELSE IF(ITG.EQ.2) THEN
         CALL LCMSIX(IPTRK,'PURE-GEOM',1)
         CALL LCMGET(IPTRK,'PARAM',IPAR)
         ITYPE=IPAR(1)
         IHEX=IPAR(2)
         IQUA2=IPAR(3)
         IF(ITYPE.GE.8) CALL LCMGET(IPTRK,'SIDE',SIDE)
         ALLOCATE(XX2(NREG+1),NCODE(6),ZCODE(6))
         CALL LCMGET(IPTRK,'XXX',XX2)
         CALL LCMGET(IPTRK,'NCODE',NCODE)
         CALL LCMGET(IPTRK,'ZCODE',ZCODE)
         CALL LCMSIX(IPTRK,' ',2)
*
         IF(ITYPE.EQ.2) THEN
            CALL SYBALP(NREG,NREG,XX2,SIGT,NCODE,ZCODE,PIJ)
         ELSE IF(ITYPE.EQ.3) THEN
            ALLOCATE(ZTR(1+IQUA2*((NREG*(5+NREG))/2)))
            CALL SYBT1D(NREG,XX2,.FALSE.,IQUA2,ZTR)
            CALL SYBALC(NREG,NREG,XX2,SIGT,IQUA2,ZCODE(2),ZTR,PIJ)
            DEALLOCATE(ZTR)
         ELSE IF(ITYPE.EQ.4) THEN
            ALLOCATE(ZTR(1+IQUA2*((NREG*(5+NREG))/2)))
            CALL SYBT1D(NREG,XX2,.TRUE.,IQUA2,ZTR)
            CALL SYBALS(NREG,NREG,XX2,SIGT,IQUA2,ZCODE(2),ZTR,PIJ)
            DEALLOCATE(ZTR)
         ENDIF
         DEALLOCATE(ZCODE,NCODE,XX2)
         CALL SYBWIJ(NREG,NREG,SIGW,PIJ)
      ELSE IF(ITG.EQ.3) THEN
         CALL LCMSIX(IPTRK,'DOITYOURSELF',1)
         CALL LCMGET(IPTRK,'PARAM',IPAR)
         NSUPCE=IPAR(1)
         IQUA3=IPAR(2)
         ISTAT=IPAR(3)
         ALLOCATE(NMC3(NSUPCE+1),RAYR3(NSUPCE+NREG),PROCE(NSUPCE**2))
         CALL LCMGET(IPTRK,'NMC',NMC3)
         CALL LCMGET(IPTRK,'RAYRE',RAYR3)
         CALL LCMGET(IPTRK,'PROCEL',PROCE)
         CALL LCMSIX(IPTRK,' ',2)
         NPIJ=0
         DO 10 IKG=1,NSUPCE
         J2=NMC3(IKG+1)-NMC3(IKG)
   10    NPIJ=NPIJ+J2*J2
*
         CALL SYBRXE(NREG,NPIJ,NSUPCE,RAYR3,SIGT,SIGW,PIJ,IQUA3,ISTAT,
     1   NMC3,PROCE,IMPX)
         DEALLOCATE(PROCE,RAYR3,NMC3)
      ELSE IF(ITG.EQ.4) THEN
         CALL LCMSIX(IPTRK,'EURYDICE',1)
         CALL LCMGET(IPTRK,'PARAM',IPAR)
         IHEX=IPAR(1)
         MULTC=IPAR(2)
         IWIGN=IPAR(3)
         NMCEL=IPAR(4)
         NMERGE=IPAR(5)
         NGEN=IPAR(6)
         IJAT=IPAR(7)
         LMAILI=IPAR(15)
         LMAILR=IPAR(16)
         ALLOCATE(LSEC4(NGEN),NMC4(NGEN+1),NMCR4(NGEN+1),MAIL(2*NGEN))
         ALLOCATE(XX4(NGEN),YY4(NGEN))
         CALL LCMGET(IPTRK,'XX',XX4)
         CALL LCMGET(IPTRK,'YY',YY4)
         CALL LCMGET(IPTRK,'LSECT',LSEC4)
         CALL LCMGET(IPTRK,'NMC',NMC4)
         CALL LCMGET(IPTRK,'NMCR',NMCR4)
         CALL LCMGET(IPTRK,'MAIL',MAIL)
         ALLOCATE(RAYR4(NMCR4(NGEN+1)))
         CALL LCMGET(IPTRK,'RAYRE',RAYR4)
         IF(LMAILI.GT.0) THEN
            CALL LCMGPD(IPTRK,'ZMAILI',IZMAI_PTR)
            CALL C_F_POINTER(IZMAI_PTR,IZMAI,(/ LMAILI /))
         ELSE
*           THIS INFO IS NOT REQUIRED IN THE CALLED ROUTINE.
            IZMAI=>IDUMMY
         ENDIF
         IF(LMAILR.GT.0) THEN
            ALLOCATE(RZMAI(LMAILR))
            CALL LCMGPD(IPTRK,'ZMAILR',RZMAI_PTR)
            CALL C_F_POINTER(RZMAI_PTR,RZMAI,(/ LMAILR /))
         ELSE
*           THIS INFO IS NOT REQUIRED IN THE CALLED ROUTINE.
            RZMAI=>DUMMY
         ENDIF
         NCOUR=4
         IF(IHEX.NE.0) NCOUR=6
         IF(MULTC.EQ.4) NCOUR=3*NCOUR
         ALLOCATE(IFR(NCOUR*NMCEL),INUM(NMCEL),MIX(NCOUR*NMERGE),
     1   IGEN(NMERGE))
         ALLOCATE(ALB(NCOUR*NMCEL),DVX(NCOUR*NMERGE))
         CALL LCMGET(IPTRK,'IFR',IFR)
         CALL LCMGET(IPTRK,'ALB',ALB)
         CALL LCMGET(IPTRK,'INUM',INUM)
         CALL LCMGET(IPTRK,'MIX',MIX)
         CALL LCMGET(IPTRK,'DVX',DVX)
         CALL LCMGET(IPTRK,'IGEN',IGEN)
         CALL LCMSIX(IPTRK,' ',2)
*
         NPIJ=0
         DO 20 IKG=1,NGEN
         J2=NMC4(IKG+1)-NMC4(IKG)
   20    NPIJ=NPIJ+J2*J2
         NPIS=NMC4(NGEN+1)
         IF(MULTC.EQ.1) THEN
            CALL SYBRX2(NREG,NPIJ,NPIS,SIGT,SIGW,PIJ,IMPX,NCOUR,
     1      IWIGN,NMCEL,NMERGE,NGEN,IPAR(8),XX4,YY4,NMC4,RAYR4,MAIL,
     2      RZMAI,IFR,ALB,INUM,IGEN)
         ELSE
            NRAYRE=NMCR4(NGEN+1)
            CALL SYBRX3(MULTC,NREG,NPIJ,NPIS,NRAYRE,SIGT,SIGW,PIJ,IMPX,
     1      NCOUR,IWIGN,NMCEL,NMERGE,NGEN,IJAT,IPAR(8),XX4,YY4,LSEC4,
     2      NMC4,NMCR4,RAYR4,MAIL,IZMAI,RZMAI,IFR,ALB,INUM,MIX,DVX,IGEN)
         ENDIF
         DEALLOCATE(DVX,ALB)
         DEALLOCATE(IGEN,MIX,INUM,IFR)
         DEALLOCATE(RAYR4,YY4,XX4)
         DEALLOCATE(MAIL,NMCR4,NMC4,LSEC4)
      ELSE
         CALL XABORT('SYBCP1: UNKNOWN CP MODULE.')
      ENDIF
*
      IF(IMPX.GE.7) THEN
         WRITE (6,1130) (J,J=1,NREG)
         DO 90 I=1,NREG
         WRITE (6,1140) I,(PIJ(I,J),J=1,NREG)
   90    CONTINUE
         WRITE (6,'(//)')
      ENDIF
      RETURN
*
 1130 FORMAT (//49H SYBCP1: SCATTERING-REDUCED COLLISION PROBABILITY,
     1 9H MATRIX ://(11X,2HJ=,I4,:,5X,2HJ=,I4,:,5X,2HJ=,I4,:,5X,2HJ=,
     2 I4,:,5X,2HJ=,I4,:,5X,2HJ=,I4,:,5X,2HJ=,I4,:,5X,2HJ=,I4,:,5X,
     3 2HJ=,I4,:,5X,2HJ=,I4,:,5X,2HJ=,I4))
 1140 FORMAT (3H I=,I4,2H: ,1P,11E11.3/(9X,11E11.3))
      END
