Initial commit from Polytechnique Montreal

1 files changed, 118 insertions, 0 deletions

diff --git a/Dragon/src/XELCOP.f b/Dragon/src/XELCOP.f
new file mode 100644
index 0000000..1da89d8
--- /dev/null
+++ b/Dragon/src/XELCOP.f
@@ -0,0 +1,118 @@
+*DECK XELCOP
+      SUBROUTINE XELCOP( IFILE1, IFILE2)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Copy the DRAGON tracking file IFILE1 over IFILE2.
+*
+*Copyright:
+* Copyright (C) 1991 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): R. Roy
+*
+*Parameters: input
+* IFILE1  first tracking file number (AT INPUT).
+* IFILE2  second tracking file number (AT OUTPUT).
+*
+*-----------------------------------------------------------------------
+*
+      IMPLICIT          NONE
+C
+      DOUBLE PRECISION  WEIGHT
+      INTEGER           IFILE1,IFILE2,NCOMNT,NTRK,IFMT,IREC,IC,IR,NDIM,
+     >                  ISPEC,NV,NS,NALBG,NCOR,NANGL,MXSUB,MXSEG,NSUB,
+     >                  LINE,NUNKNO
+      CHARACTER         CTRK*4, COMENT*80
+      INTEGER           IOUT
+      PARAMETER       ( IOUT=6 )
+C----
+C  ALLOCATABLE ARRAYS
+C----
+      INTEGER, ALLOCATABLE, DIMENSION(:) :: MATALB,ICODE,NRSEG,KANGL
+      REAL, ALLOCATABLE, DIMENSION(:) :: VOLSUR,ALBEDO
+      DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: ANGLES,DENSTY
+      DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: SEGLEN
+C
+C.1)  READ AND COPY FIRST RECORDS (HEADER, COMMENTS) ------------------
+C
+      IREC= 1
+      READ (IFILE1,ERR=991) CTRK,NCOMNT,NTRK,IFMT
+      WRITE(IFILE2,ERR=992) CTRK,NCOMNT,NTRK,IFMT
+      DO 10 IC= 1, NCOMNT
+         IREC= IREC+1
+         READ (IFILE1,ERR=991) COMENT
+         WRITE(IFILE2,ERR=992) COMENT
+   10 CONTINUE
+C
+C.2)  READ AND COPY MAIN RECORD AND GET USEFUL DIMENSIONS -------------
+C
+      IREC= IREC+1
+      READ (IFILE1,ERR=991) NDIM,ISPEC,NV,NS,NALBG,NCOR,NANGL,MXSUB,
+     > MXSEG
+      WRITE(IFILE2,ERR=992) NDIM,ISPEC,NV,NS,NALBG,NCOR,NANGL,MXSUB,
+     > MXSEG
+      NUNKNO= NV+NS+1
+C
+C.2.1) ALLOCATE SPACE TO COPY SUBSEQUENT RECORDS
+      ALLOCATE(MATALB(NUNKNO),ICODE(NALBG),NRSEG(MXSEG),KANGL(MXSUB))
+      ALLOCATE(VOLSUR(NUNKNO),ALBEDO(NALBG),ANGLES(NDIM*NANGL),
+     > DENSTY(NANGL),SEGLEN(MXSEG))
+C
+C.2.2) COPY ALL RECORDS BEFORE TRACKS
+      IREC= IREC+1
+      READ (IFILE1,ERR=991) (VOLSUR(IR),IR=1,NUNKNO)
+      WRITE(IFILE2,ERR=992) (VOLSUR(IR),IR=1,NUNKNO)
+      IREC= IREC+1
+      READ (IFILE1,ERR=991) (MATALB(IR),IR=1,NUNKNO)
+      WRITE(IFILE2,ERR=992) (MATALB(IR),IR=1,NUNKNO)
+      IREC= IREC+1
+      READ (IFILE1,ERR=991) (ICODE(IR),IR=1,NALBG)
+      WRITE(IFILE2,ERR=992) (ICODE(IR),IR=1,NALBG)
+      IREC= IREC+1
+      READ (IFILE1,ERR=991) (ALBEDO(IR),IR=1,NALBG)
+      WRITE(IFILE2,ERR=992) (ALBEDO(IR),IR=1,NALBG)
+      IREC= IREC+1
+      READ (IFILE1,ERR=991) (ANGLES(IR),IR=1,NDIM*NANGL)
+      WRITE(IFILE2,ERR=992) (ANGLES(IR),IR=1,NDIM*NANGL)
+      IREC= IREC+1
+      READ (IFILE1,ERR=991) (DENSTY(IR),IR=1,NANGL)
+      WRITE(IFILE2,ERR=992) (DENSTY(IR),IR=1,NANGL)
+C
+C.3)   NOW, COPY ALL TRACKS -------------------------------------------
+C
+   20 CONTINUE
+         IREC= IREC + 1
+         READ (IFILE1,END=40,ERR=991) NSUB,LINE,WEIGHT,
+     >                      (KANGL(IR),IR=1,NSUB),
+     >                      (NRSEG(IR),IR=1,LINE),(SEGLEN(IR),IR=1,LINE)
+         IF(NSUB.GT.MXSUB) CALL XABORT('XELCOP: MXSUB OVERFLOW.')
+         WRITE(IFILE2,       ERR=992) NSUB,LINE,WEIGHT,
+     >                      (KANGL(IR),IR=1,NSUB),
+     >                      (NRSEG(IR),IR=1,LINE),(SEGLEN(IR),IR=1,LINE)
+      GO TO 20
+C
+   40 CONTINUE
+C
+C.4)   RELEASE TEMPORARY SPACE AND REWIND BOTH FILES ------------------
+C
+      DEALLOCATE(KANGL,SEGLEN,DENSTY,ANGLES,ALBEDO,VOLSUR)
+      DEALLOCATE(NRSEG,ICODE,MATALB)
+      REWIND IFILE1
+      REWIND IFILE2
+      RETURN
+C
+  991 WRITE(IOUT,'(30H ERROR= RECORD DESTROYED...    )')
+      WRITE(IOUT,'(31H ERROR= UNABLE TO READ  RECORD ,I10)') IREC
+      WRITE(IOUT,'(31H ERROR=              ON FILE FT,I2.2)') IFILE1
+      CALL XABORT( 'XELCOP: --- READ  TRACKING FILE FAILED' )
+  992 WRITE(IOUT,'(30H ERROR= NOT ENOUGH SPACE...    )')
+      WRITE(IOUT,'(31H ERROR= UNABLE TO WRITE RECORD ,I8.8)') IREC
+      WRITE(IOUT,'(31H ERROR=              ON FILE FT,I2.2)') IFILE1
+      CALL XABORT( 'XELCOP: --- WRITE TRACKING FILE FAILED' )
+C
+      END