1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
|
*DECK EDIJO2
SUBROUTINE EDIJO2(IPMAC2,IPTRK1,IPFLUX,IPRINT,NGCOND,IGCOND)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Recover ALBS information from last component of unknown array for use
* with SPH equivalence techniques. MCCG compatible version.
*
*Copyright:
* Copyright (C) 2019 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)
REAL ALBEDO(6)
CHARACTER CDOOR*12
*----
* ALLOCATABLE ARRAYS
*----
INTEGER, ALLOCATABLE, DIMENSION(:) :: NZON,KEYSUR
REAL, ALLOCATABLE, DIMENSION(:) :: WORKD,VOLSUR
REAL, ALLOCATABLE, DIMENSION(:,:) :: OUTG
*----
* RECOVER FLUX OBJECT INFORMATION
*----
CALL LCMGET(IPFLUX,'STATE-VECTOR',ISTATE)
NUNKNO=ISTATE(2)
*----
* RECOVER TRACKING INFORMATION
*----
CALL LCMGTC(IPTRK1,'TRACK-TYPE',12,CDOOR)
CALL LCMGET(IPTRK1,'STATE-VECTOR',ISTATE)
IF(CDOOR.NE.'MCCG') CALL XABORT('EDIJO2: MCCG TRACKING EXPECTED.')
NBVOL=ISTATE(1)
NBSUR=ISTATE(5)
IF(NBSUR.EQ.0) CALL XABORT('EDIJO2: NO BOUNDARY LEAKAGE.')
ALLOCATE(VOLSUR(NBVOL+NBSUR),NZON(NBVOL+NBSUR),KEYSUR(NBSUR))
CALL LCMGET(IPTRK1,'V$MCCG',VOLSUR)
CALL LCMGET(IPTRK1,'NZON$MCCG',NZON)
CALL LCMGET(IPTRK1,'KEYCUR$MCCG',KEYSUR)
CALL LCMGET(IPTRK1,'ALBEDO',ALBEDO)
*----
* COMPUTE THE OUTGOING CURRENT
*----
ALLOCATE(OUTG(NGCOND,2))
IGRFIN=0
CALL LCMSIX(IPMAC2,'ADF',1)
ALLOCATE(WORKD(NUNKNO))
DO 30 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('EDIJO2: MISSING FLUX INFO(1).')
JPFLUX=LCMGID(IPFLUX,'FLUX')
DO 20 IGR=IGRDEB,IGRFIN
CALL LCMLEL(JPFLUX,IGR,ILONG,ITYLCM)
IF(ILONG.NE.NUNKNO) CALL XABORT('EDIJO2: MISSING FLUX INFO(2).')
CALL LCMGDL(JPFLUX,IGR,WORKD)
DO 10 IS=1,NBSUR
IUN=KEYSUR(IS)
IF(IUN.EQ.0) GO TO 10
IAL=-NZON(NBVOL+IS)
OUTG(IGRCD,1)=OUTG(IGRCD,1)+WORKD(IUN)*VOLSUR(NBVOL+IS)
OUTG(IGRCD,2)=OUTG(IGRCD,2)+WORKD(IUN)*VOLSUR(NBVOL+IS)*
> ALBEDO(IAL)
10 CONTINUE
20 CONTINUE
30 CONTINUE
DEALLOCATE(WORKD)
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(KEYSUR,NZON,VOLSUR)
DEALLOCATE(OUTG)
RETURN
*
900 FORMAT(/49H EDIJO2: OUT-CURRENTS (4J-/S) PER MACRO-GROUP ARE/
> (1X,1P,10E13.5))
910 FORMAT(/49H EDIJO2: IN-CURRENTS (4J+/S) PER MACRO-GROUP ARE/
> (1X,1P,10E13.5))
END
|
