diff options
Diffstat (limited to 'Dragon/src/XELCOP.f')
| -rw-r--r-- | Dragon/src/XELCOP.f | 118 |
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 |