1 files changed, 109 insertions, 0 deletions
diff --git a/Dragon/src/NXTSQD.f b/Dragon/src/NXTSQD.f
new file mode 100644
index 0000000..edd6a55
--- /dev/null
+++ b/Dragon/src/NXTSQD.f
@@ -0,0 +1,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