diff options
Diffstat (limited to 'Dragon/src/SYBCP1.f')
| -rw-r--r-- | Dragon/src/SYBCP1.f | 192 |
1 files changed, 192 insertions, 0 deletions
diff --git a/Dragon/src/SYBCP1.f b/Dragon/src/SYBCP1.f new file mode 100644 index 0000000..713c338 --- /dev/null +++ b/Dragon/src/SYBCP1.f @@ -0,0 +1,192 @@ +*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) + NPIJ=NPIJ+J2*J2 + 10 CONTINUE +* + 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 + 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) + NPIJ=NPIJ+J2*J2 + 20 CONTINUE + 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 |