diff options
Diffstat (limited to 'Dragon/src/EDIJO1.f')
| -rw-r--r-- | Dragon/src/EDIJO1.f | 172 |
1 files changed, 172 insertions, 0 deletions
diff --git a/Dragon/src/EDIJO1.f b/Dragon/src/EDIJO1.f new file mode 100644 index 0000000..f941c9d --- /dev/null +++ b/Dragon/src/EDIJO1.f @@ -0,0 +1,172 @@ +*DECK EDIJO1 + SUBROUTINE EDIJO1(IPMAC2,IPTRK1,IPFLUX,IPRINT,NGCOND,IGCOND) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover ALBS information from last component of unknown array for use +* with SPH equivalence techniques. SYBILF compatible version. SYBILF is +* activated with ARM keyword in ASM: module. +* +*Copyright: +* Copyright (C) 2015 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 +* IPMAC2 pointer to condensed macrolib information (L_MACROLIB +* signature) built by EDI:. +* IPTRK1 pointer to the reference tracking object. +* IPFLUX pointer to the reference solution (L_FLUX signature). +* IPRINT print index. +* NGCOND number of condensed groups. +* IGCOND limit of condensed groups. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMAC2,IPTRK1,IPFLUX + INTEGER IPRINT,NGCOND,IGCOND(NGCOND) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + TYPE(C_PTR) JPFLUX + INTEGER ISTATE(NSTATE),IPAR(16) + CHARACTER CDOOR*12 +*---- +* ALLOCATABLE ARRAYS +*---- + TYPE(C_PTR) IFR_PTR,ALB_PTR,SUR_PTR,INUM_PTR,MIX_PTR + INTEGER, POINTER, DIMENSION(:) :: IFR,INUM,MIX + REAL, POINTER, DIMENSION(:) :: ALB,SUR + REAL, ALLOCATABLE, DIMENSION(:) :: WORKD + REAL, ALLOCATABLE, DIMENSION(:,:) :: OUTG +*---- +* RECOVER FLUX OBJECT INFORMATION +*---- + CALL LCMGET(IPFLUX,'STATE-VECTOR',ISTATE) + NUNKNO=ISTATE(2) + ILEAK=ISTATE(7) +*---- +* RECOVER TRACKING INFORMATION +*---- + CALL LCMGTC(IPTRK1,'TRACK-TYPE',12,CDOOR) + IF(CDOOR.NE.'SYBIL') CALL XABORT('EDIJO1: SYBIL TRACKING EXPECTE' + > //'D.') + CALL LCMGET(IPTRK1,'STATE-VECTOR',ISTATE) + NREG=ISTATE(1) + ITG=ISTATE(6) + IF(ITG.NE.4) CALL XABORT('EDIJO1: JOUT OPTION FORBIDDEN.') + NUNKNO=ISTATE(2)+ISTATE(9) + CALL LCMSIX(IPTRK1,'EURYDICE',1) + CALL LCMGET(IPTRK1,'PARAM',IPAR) + IHEX=IPAR(1) + MULTC=IPAR(2) + NMCEL=IPAR(4) + NMERGE=IPAR(5) + NCOUR=4 + IF(IHEX.NE.0) NCOUR=6 + IF(MULTC.EQ.4) NCOUR=3*NCOUR + CALL LCMGPD(IPTRK1,'IFR',IFR_PTR) + CALL LCMGPD(IPTRK1,'ALB',ALB_PTR) + CALL LCMGPD(IPTRK1,'SUR',SUR_PTR) + CALL LCMGPD(IPTRK1,'INUM',INUM_PTR) + CALL LCMGPD(IPTRK1,'MIX',MIX_PTR) + CALL LCMSIX(IPTRK1,' ',2) +* + CALL C_F_POINTER(IFR_PTR,IFR,(/ NCOUR*NMCEL /)) + CALL C_F_POINTER(ALB_PTR,ALB,(/ NCOUR*NMCEL /)) + CALL C_F_POINTER(SUR_PTR,SUR,(/ NCOUR*NMCEL /)) + CALL C_F_POINTER(INUM_PTR,INUM,(/ NMCEL /)) + CALL C_F_POINTER(MIX_PTR,MIX,(/ NCOUR*NMERGE /)) +*---- +* COMPUTE THE OUTGOING CURRENT +*---- + ALLOCATE(OUTG(NGCOND,2)) + IGRFIN=0 + CALL LCMSIX(IPMAC2,'ADF',1) + DO 70 IGRCD=1,NGCOND + OUTG(IGRCD,:2)=0.0 + IGRDEB=IGRFIN+1 + IGRFIN=IGCOND(IGRCD) + CALL LCMLEN(IPFLUX,'FLUX',ILON,ITYLCM) + IF(ILON.EQ.0) CALL XABORT('EDIJO1: MISSING FLUX INFO(1).') + JPFLUX=LCMGID(IPFLUX,'FLUX') + DO 60 IGR=IGRDEB,IGRFIN + CALL LCMLEL(JPFLUX,IGR,ILCMLN,ITYLCM) + IF(ILCMLN.EQ.0) CALL XABORT('EDIJO1: MISSING FLUX INFO(2).') + IF(ILEAK.LE.5) THEN + IF(ILCMLN.NE.NUNKNO) CALL XABORT('EDIJO1: ARM KEYWORD MUST B' + 1 //'E SET IN ASM: MODULE(1).') + ALLOCATE(WORKD(NUNKNO)) + ELSE IF(ILEAK.EQ.6) THEN + IF(ILCMLN.NE.2*NUNKNO) CALL XABORT('EDIJO1: ARM KEYWORD MUST' + 1 //' BE SET IN ASM: MODULE(2).') + ALLOCATE(WORKD(2*NUNKNO)) + ELSE + CALL XABORT('EDIJO1: INVALID TYPE OF LEAKAGE.') + ENDIF + CALL LCMGDL(JPFLUX,IGR,WORKD) + OUTC1=0.0 + OUTC2=0.0 + SURT=0.0 + IF(MULTC.EQ.1) THEN + DO 20 ICEL=1,NMCEL + IKK=INUM(ICEL) + IF(IKK.EQ.0) GO TO 20 + IT0=NCOUR*(ICEL-1) + DO 10 JC=1,NCOUR + IF((IKK.EQ.IFR(IT0+JC)).AND.(SUR(IT0+JC).NE.0.0)) THEN + J1=IFR(IT0+JC) + OUTC1=OUTC1+WORKD(NREG+J1)*SUR(IT0+JC) + OUTC2=OUTC2+WORKD(NREG+J1)*SUR(IT0+JC)*ALB(IT0+JC) + SURT=SURT+SUR(IT0+JC) + ENDIF + 10 CONTINUE + 20 CONTINUE + ELSE + ISTR=1 + IF((NCOUR.EQ.12).OR.(NCOUR.EQ.18)) ISTR=3 + DO 50 ICEL=1,NMCEL + IKK=INUM(ICEL) + IF(IKK.EQ.0) GO TO 50 + IT0=NCOUR*(ICEL-1) + IT1=NCOUR*(IKK-1) + DO 40 JC=1,NCOUR,ISTR + IF((MIX(IT1+JC).EQ.IFR(IT0+JC)).AND.(SUR(IT0+JC).NE.0.0)) THEN + J1=IFR(IT0+JC) + OUTC1=OUTC1+WORKD(NREG+J1)*SUR(IT0+JC) + OUTC2=OUTC2+WORKD(NREG+J1)*SUR(IT0+JC)*ALB(IT0+JC) + SURT=SURT+SUR(IT0+JC) + ENDIF + 40 CONTINUE + 50 CONTINUE + ENDIF + OUTG(IGRCD,1)=OUTG(IGRCD,1)+OUTC1/SURT + OUTG(IGRCD,2)=OUTG(IGRCD,2)+OUTC2/SURT + DEALLOCATE(WORKD) + 60 CONTINUE + 70 CONTINUE + CALL LCMPUT(IPMAC2,'ALBS00',NGCOND*2,2,OUTG) + IF(IPRINT.GT.3) THEN + WRITE(6,900) (OUTG(IGR,1),IGR=1,NGCOND) + WRITE(6,910) (OUTG(IGR,2),IGR=1,NGCOND) + WRITE(6,'(/)') + ENDIF + CALL LCMSIX(IPMAC2,' ',2) + DEALLOCATE(OUTG) + RETURN +* + 900 FORMAT(/49H EDIJO1: OUT-CURRENTS (4J-/S) PER MACRO-GROUP ARE/ + > (1X,1P,10E13.5)) + 910 FORMAT(/49H EDIJO1: IN-CURRENTS (4J+/S) PER MACRO-GROUP ARE/ + > (1X,1P,10E13.5)) + END |