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
|
*DECK SCRMEM
SUBROUTINE SCRMEM(IPSAP,IPMEM,NCAL,NMIL,NMIX,TERP,MIXC)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Copy a Saphyb into memory taking care to keep only required
* calculations and mixtures.
*
*Copyright:
* Copyright (C) 2013 Ecole Polytechnique de Montreal
*
*Author(s):
* A. Hebert
*
*Parameters: input
* IPSAP address of the Saphyb object.
* IPMEM address of the simplified Saphyb in memory created by SCRMEM.
* NCAL number of elementary calculations in the Saphyb.
* NMIL number of material mixtures in the Saphyb
* NMIX maximum number of material mixtures in the microlib.
* TERP interpolation factors.
* MIXC mixture index in the Saphyb corresponding to each microlib
* mixture.
*
*-----------------------------------------------------------------------
*
USE GANLIB
IMPLICIT NONE
*----
* SUBROUTINE ARGUMENTS
*----
TYPE(C_PTR) IPSAP,IPMEM
INTEGER NCAL,NMIL,NMIX,MIXC(NMIX)
REAL TERP(NCAL,NMIX)
*----
* LOCAL VARIABLES
*----
INTEGER DIMSAP(50)
INTEGER IBM, IBMOLD, ICAL, ILONG, ITYLCM
CHARACTER SIGN*12,TEXT12*12
TYPE(C_PTR) JPSAP,KPSAP,JPMEM1,JPMEM2,KPMEM1,KPMEM2
*
CALL LCMOP(IPMEM,'*tempSaphyb*',0,1,0)
CALL LCMGTC(IPSAP,'SIGNATURE',12,SIGN)
CALL LCMPTC(IPMEM,'SIGNATURE',12,SIGN)
CALL LCMGET(IPSAP,'DIMSAP',DIMSAP)
CALL LCMPUT(IPMEM,'DIMSAP',50,1,DIMSAP)
JPSAP=LCMGID(IPSAP,'constphysiq')
JPMEM1=LCMDID(IPMEM,'constphysiq')
CALL LCMEQU(JPSAP,JPMEM1)
JPSAP=LCMGID(IPSAP,'contenu')
JPMEM1=LCMDID(IPMEM,'contenu')
CALL LCMEQU(JPSAP,JPMEM1)
JPSAP=LCMGID(IPSAP,'adresses')
JPMEM1=LCMDID(IPMEM,'adresses')
CALL LCMEQU(JPSAP,JPMEM1)
JPSAP=LCMGID(IPSAP,'geom')
JPMEM1=LCMDID(IPMEM,'geom')
CALL LCMEQU(JPSAP,JPMEM1)
JPMEM1=LCMLID(IPMEM,'calc',NCAL)
DO 30 ICAL=1,NCAL
DO IBM=1,NMIX
IF(TERP(ICAL,IBM).NE.0.0) GO TO 10
ENDDO
GO TO 30
10 WRITE(TEXT12,'(4Hcalc,I8)') ICAL
JPSAP=LCMGID(IPSAP,TEXT12)
JPMEM2=LCMDIL(JPMEM1,ICAL)
KPSAP=LCMGID(JPSAP,'info')
KPMEM1=LCMDID(JPMEM2,'info')
CALL LCMEQU(KPSAP,KPMEM1)
KPSAP=LCMGID(JPSAP,'divers')
KPMEM1=LCMDID(JPMEM2,'divers')
CALL LCMEQU(KPSAP,KPMEM1)
CALL LCMLEN(JPSAP,'outflx',ILONG,ITYLCM)
IF(ILONG.NE.0) THEN
KPSAP=LCMGID(JPSAP,'outflx')
KPMEM1=LCMDID(JPMEM2,'outflx')
CALL LCMEQU(KPSAP,KPMEM1)
ENDIF
KPMEM1=LCMLID(JPMEM2,'mili',NMIL)
DO IBMOLD=1,NMIL
DO IBM=1,NMIX
IF((TERP(ICAL,IBM).NE.0.).AND.(MIXC(IBM).EQ.IBMOLD)) GO TO 20
ENDDO
CYCLE
20 WRITE(TEXT12,'(4Hmili,I8)') IBMOLD
KPSAP=LCMGID(JPSAP,TEXT12)
KPMEM2=LCMDIL(KPMEM1,IBMOLD)
CALL LCMEQU(KPSAP,KPMEM2)
ENDDO
30 CONTINUE
RETURN
END
|
