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
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
|
*DECK APXIDF
SUBROUTINE APXIDF(IPAPX,IPEDIT,NG,NMIL,ICAL,IDF,NALBP,FNORM,
1 VOLMIL,FLXMIL)
*
*-----------------------------------------------------------------------
*
*Purpose:
* To store discontinuity factor and albedo information in the Apex file.
*
*Copyright:
* Copyright (C) 2025 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
* IPAPX pointer to the Apex file.
* IPEDIT pointer to the edition object (L_EDIT signature).
* NG number of condensed energy groups.
* NMIL number of mixtures.
* ICAL index of the current elementary calculation.
* IDF type of surfacic information (2/3: boundary flux/DF).
* NALBP number of physical albedos per energy group.
* FNORM flux normalization factor.
* VOLMIL mixture volumes.
* FLXMIL averaged flux of mixtures.
*
*-----------------------------------------------------------------------
*
USE GANLIB
USE hdf5_wrap
*----
* SUBROUTINE ARGUMENTS
*----
TYPE(C_PTR) IPAPX,IPEDIT
INTEGER NG,NMIL,ICAL,IDF,NALBP
REAL FNORM,VOLMIL(NMIL),FLXMIL(NMIL,NG)
*----
* LOCAL VARIABLES
*----
CHARACTER HSMG*131,RECNAM*80,RECNAM2*80
*----
* ALLOCATABLE ARRAYS
*----
REAL, ALLOCATABLE, DIMENSION(:) :: SURF
REAL, ALLOCATABLE, DIMENSION(:,:) :: VREAL,ALBP
REAL, ALLOCATABLE, DIMENSION(:,:,:) :: DISFAC
CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: HADF
*----
* RECOVER DISCONTINUITY FACTOR INFORMATION FROM MACROLIB
*----
CALL LCMSIX(IPEDIT,'MACROLIB',1)
CALL LCMLEN(IPEDIT,'ADF',ILONG,ITYLCM)
IF(ILONG.NE.0) THEN
CALL LCMSIX(IPEDIT,'ADF',1)
CALL LCMGET(IPEDIT,'NTYPE',NSURFD)
NGG=0
IF((IDF.EQ.2).OR.(IDF.EQ.3)) THEN
NGG=NG
ELSE
CALL XABORT('APXIDF: INVALID ADF OPTION.')
ENDIF
ALLOCATE(DISFAC(NSURFD,NGG,NMIL),SURF(NMIL*NGG),HADF(NSURFD))
CALL LCMGTC(IPEDIT,'HADF',8,NSURFD,HADF)
DO I=1,NSURFD
CALL LCMLEN(IPEDIT,HADF(I),ILONG,ITYLCM)
IF(IDF.EQ.2) THEN
* boundary flux information
IF(ILONG.NE.NMIL*NG) THEN
WRITE(HSMG,'(16HAPXIDF: INVALID ,A,8H LENGTH=,I5,
1 10H EXPECTED=,I5,4H.(1))') HADF(I),ILONG,NMIL*NG
CALL XABORT(HSMG)
ENDIF
CALL LCMGET(IPEDIT,HADF(I),SURF)
DO IMIL=1,NMIL
DO IGR=1,NG
IF(FNORM.NE.1.0) THEN
DISFAC(I,IGR,IMIL)=SURF((IGR-1)*NMIL+IMIL)*
1 FNORM*1.0E13*VOLMIL(IMIL)/FLXMIL(IMIL,IGR)
ELSE
DISFAC(I,IGR,IMIL)=SURF((IGR-1)*NMIL+IMIL)*
1 VOLMIL(IMIL)/FLXMIL(IMIL,IGR)
ENDIF
ENDDO
ENDDO
ELSE IF(IDF.EQ.3) THEN
* discontinuity factor information
IF(ILONG.NE.NMIL*NG) THEN
WRITE(HSMG,'(16HAPXIDF: INVALID ,A,8H LENGTH=,I5,
1 10H EXPECTED=,I5,4H.(2))') HADF(I),ILONG,NMIL*NG
CALL XABORT(HSMG)
ENDIF
CALL LCMGET(IPEDIT,HADF(I),SURF)
DO IMIL=1,NMIL
DO IGR=1,NG
IOF=(IGR-1)*NMIL+IMIL
DISFAC(I,IGR,IMIL)=SURF(IOF)
ENDDO
ENDDO
ENDIF
ENDDO
DEALLOCATE(HADF,SURF)
CALL LCMSIX(IPEDIT,' ',2)
*----
* MOVE TO THE /calc_id/miscellaneous/ GROUP.
*----
WRITE(RECNAM,'(4Hcalc,I8,15H/miscellaneous/)') ICAL
IF((IDF.EQ.2).OR.(IDF.EQ.3)) THEN
IF(NMIL.EQ.1) THEN
ALLOCATE(VREAL(NSURFD,NG))
VREAL(:NSURFD,:NG)=DISFAC(:NSURFD,:NG,1)
CALL hdf5_write_data(IPAPX,TRIM(RECNAM)//"ADF",VREAL)
DEALLOCATE(VREAL)
ELSE
DO IMIL=1,NMIL
WRITE(RECNAM2,'(A,3HADF,I8)') TRIM(RECNAM),IMIL
ALLOCATE(VREAL(NSURFD,NG))
VREAL(:NSURFD,:NG)=DISFAC(:NSURFD,:NG,IMIL)
CALL hdf5_write_data(IPAPX,TRIM(RECNAM2),VREAL)
DEALLOCATE(VREAL)
ENDDO
ENDIF
ENDIF
DEALLOCATE(DISFAC)
ENDIF
*----
* RECOVER AND SAVE ALBEDO INFORMATION
*----
IF(NALBP.NE.0) THEN
WRITE(RECNAM,'(4Hcalc,I8,15H/miscellaneous/)') ICAL
CALL LCMLEN(IPEDIT,'ALBEDO',ILONG,ITYLCM)
IF(ILONG.EQ.NALBP*NG) THEN
ALLOCATE(ALBP(NALBP,NG))
CALL LCMGET(IPEDIT,'ALBEDO',ALBP)
CALL hdf5_write_data(IPAPX,TRIM(RECNAM)//"ALBEDO",ALBP)
DEALLOCATE(ALBP)
ELSE
CALL XABORT('APXIDF: INCONSISTENT ALBEDO INFORMATION.')
ENDIF
ENDIF
CALL LCMSIX(IPEDIT,' ',2)
RETURN
END
|
