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
|
*DECK NXTSQD
SUBROUTINE NXTSQD(IFTRK ,IPRINT,NDIM ,NQUAD ,NBANGL,
> DANGLT,DDENWT)
*
*-----------------------------------------------------------------------
*
*Purpose:
* To transform double precision to simple precision
* quadrature and save on IFTRK.
*
*Copyright:
* Copyright (C) 2005 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):
* G. Marleau
*
*Parameters: input
* IFTRK pointer to the TRACKING file in creation mode.
* IPRINT print level.
* NDIM number of dimensions for geometry.
* NQUAD number of quadrant (in 3-D) and quarter (in 2-D).
* NBANGL number of angles.
* DANGLT angles (double precision).
* DDENWT angular density for each angle (double precision).
*
*Reference:
* G. Marleau,
* New Geometries Processing in DRAGON: The NXT: Module,
* Report IGE-260, Polytechnique Montreal,
* Montreal, 2005.
*
*----------
*
IMPLICIT NONE
*----
* Subroutine arguments
*----
INTEGER IFTRK,IPRINT
INTEGER NDIM,NQUAD,NBANGL
DOUBLE PRECISION DANGLT(NDIM,NQUAD,NBANGL),DDENWT(NQUAD,NBANGL)
*----
* Local parameters
*----
INTEGER IOUT
CHARACTER NAMSBR*6
PARAMETER (IOUT=6,NAMSBR='NXTSQD')
*----
* Local variables
*----
INTEGER II,IJ,IK,JJ
*----
* Allocatable arrays
*----
DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: ANGLT,DENWT
*----
* Scratch storage allocation
* ANGLT angles.
* DENWT angular density for each angle.
*----
ALLOCATE(ANGLT(NDIM*NQUAD*NBANGL),DENWT(NQUAD*NBANGL))
*----
* Processing starts:
* print routine opening header if required
* and initialize various parameters.
*----
IF(IPRINT .GE. 100) THEN
WRITE(IOUT,6000) NAMSBR
ENDIF
JJ=0
DO IK=1,NBANGL
DO IJ=1,NQUAD
DO II=1,NDIM
JJ=JJ+1
ANGLT(JJ)=DANGLT(II,IJ,IK)
ENDDO
ENDDO
ENDDO
JJ=0
DO IK=1,NBANGL
DO IJ=1,NQUAD
JJ=JJ+1
DENWT(JJ)=DDENWT(IJ,IK)
ENDDO
ENDDO
WRITE(IFTRK) (ANGLT(JJ),JJ=1,NQUAD*NBANGL*NDIM)
WRITE(IFTRK) (DENWT(JJ),JJ=1,NQUAD*NBANGL)
*----
* Processing finished:
* print routine closing output header if required
* and return
*----
IF(IPRINT .GE. 100) THEN
WRITE(IOUT,6001) NAMSBR
ENDIF
*----
* Scratch storage deallocation
*----
DEALLOCATE(DENWT,ANGLT)
RETURN
*----
* Output formats
*----
6000 FORMAT('(* Output from --',A6,'-- follows ')
6001 FORMAT(' Output from --',A6,'-- completed *)')
END
|
