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
|
*DECK INFAPL
SUBROUTINE INFAPL(CFILNA,IPRINT,NBISO,HNAMIS,AWR)
*
*-----------------------------------------------------------------------
*
*Purpose:
* To recover mass for isotopes of APOLIB libraries.
*
*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
* CFILNA APOLIB1 file name.
* IPRINT print flag.
* NBISO number of isotopes.
* HNAMIS isotope names.
*
*Parameters: output
* AWR isotope weights.
*
*-----------------------------------------------------------------------
*
IMPLICIT NONE
*----
* PARAMETERS
*----
INTEGER IOUT,MAXIT
PARAMETER (IOUT=6,MAXIT=1000)
*----
* FUNCTIONS
*----
INTEGER KDROPN,KDRCLS
DOUBLE PRECISION XDRCST
*----
* LOCAL VARIABLES
*----
INTEGER NBISO,IPRINT,IUNIT,IISO,INDLOR,NR,NIT,I,K,IMX,NISB,
1 NRST,ICC,NS1,IC,NRSTR,NN,IER
INTEGER IT(MAXIT)
*
REAL AA
REAL AWR(NBISO)
CHARACTER CFILNA*64,HNAMIS(NBISO)*8,HNISOR*8,FORM*4
EQUIVALENCE(AA,NN)
REAL CONVM
*----
* OPEN APOLIB
*----
CONVM=REAL(XDRCST('Neutron mass','amu'))
IF( IPRINT.GT.0 ) THEN
WRITE(IOUT,6000) CFILNA
ENDIF
IUNIT=KDROPN(CFILNA,2,2,0)
IF( IUNIT.LE.0 )THEN
WRITE(IOUT,9000) CFILNA
CALL XABORT('INFAPL: APOL LIBRARY CANNOT BE OPENED')
ENDIF
IISO= 0
REWIND(IUNIT)
50 READ(IUNIT) INDLOR,NR,NIT,(IT(I),I=1,NIT)
IF( NIT.GT.MAXIT ) CALL XABORT('INFAPL: MAXIT IS TOO SMALL')
IF(INDLOR.EQ.9999) GO TO 700
DO 70 IMX=1,NBISO
HNISOR= HNAMIS(IMX)
I=INDEX(HNISOR,' ')
IF(I.EQ.0) THEN
READ(HNISOR,'(I8)') NISB
ELSE
WRITE(FORM,'(2H(I,I1,1H))') I-1
READ(HNISOR,FORM) NISB
ENDIF
IF( NISB.EQ.INDLOR )THEN
IF( IPRINT.GT.0 ) WRITE(IOUT,6001) HNISOR
IISO= IISO + 1
NRST= IT(4)
NS1= 0
IF( IT(5).LT.0 ) NS1= -IT(5)
IC=5+NS1+NRST
NRSTR=IT(IC)
ICC=IC+6*NRSTR+1
NN=IT(ICC)
AWR(IMX)=AA*CONVM
ENDIF
70 CONTINUE
DO 80 K=1,NR
READ(IUNIT)
80 CONTINUE
GO TO 50
*
* CHECK IF ALL NBISO ISOTOPES HAVE BEEN PROCESSED.
700 IF( IISO.NE.NBISO )THEN
CALL XABORT('INFAPL: SOME ISOTOPES WERE NOT RECOVERED')
ENDIF
*
* CLOSE APOLIB FILE.
IER=KDRCLS(IUNIT,1)
IF(IER.LT.0) CALL XABORT(
> 'INFAPL: Impossible to close library '//CFILNA)
RETURN
*
9000 FORMAT(/' ERROR IN PROCESSING APOL LIBRARY:',A8)
6000 FORMAT(/' PROCESSING APOL LIBRARY NAME ',A8)
6001 FORMAT(/' PROCESSING ISOTOPE/MATERIAL = ',A12)
END
|
