diff options
Diffstat (limited to 'Trivac/src/OUT.f')
| -rwxr-xr-x | Trivac/src/OUT.f | 188 |
1 files changed, 188 insertions, 0 deletions
diff --git a/Trivac/src/OUT.f b/Trivac/src/OUT.f new file mode 100755 index 0000000..7c1f2bb --- /dev/null +++ b/Trivac/src/OUT.f @@ -0,0 +1,188 @@ +*DECK OUT + SUBROUTINE OUT(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Simple edition module for TRIVAC-3. +* +*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/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1): create or modification type(L_MACROLIB); +* HENTRY(2): read-only type(L_FLUX); +* HENTRY(3): read-only type(L_TRACK); +* HENTRY(4): read-only type(L_MACROLIB); +* HENTRY(5): read-only type(L_GEOM). +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*Comments: +* The OUT: calling specifications are: +* MACRO2 := OUT: FLUX TRACK MACRO GEOM :: (out\_data) ; +* where +* MACRO2 : name of the \emph{lcm} object (type L\_MACROLIB) containing the +* extended \emph{macrolib}. +* FLUX : name of the \emph{lcm} object (type L\_FLUX) containing a solution +* TRACK : name of the \emph{lcm} object (type L\_TRACK) containing a +* \emph{tracking}. +* MACRO : name of the \emph{lcm} object (type L\_MACROLIB) containing the +* reference \emph{macrolib}. +* GEOM : name of the \emph{lcm} object (type L\_GEOM) containing the +* reference \emph{geometry}. +* out\_data}] : structure containing the data to module OUT: +* +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + CHARACTER TEXT12*12,TITLE*72,HTRACK*12,HSIGN*12 + INTEGER IGP(NSTATE) + TYPE(C_PTR) IPMAC1,IPMAC2,IPFLUX,IPTRK,IPGEOM + INTEGER, DIMENSION(:),ALLOCATABLE :: MAT,IDL + REAL, DIMENSION(:),ALLOCATABLE :: VOL +*---- +* PARAMETER VALIDATION. +*---- + IF(NENTRY.LE.1) CALL XABORT('OUT: TWO PARAMETERS EXPECTED.') + IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) CALL XABORT('OUT: LCM ' + 1 //'OBJECT EXPECTED AT LHS.') + IF(JENTRY(1).NE.0) CALL XABORT('OUT: ENTRY IN CREATE MODE EXPECT' + 1 //'ED.') + IF((JENTRY(2).NE.2).OR.((IENTRY(2).NE.1).AND.(IENTRY(2).NE.2))) + 1 CALL XABORT('OUT: LCM OBJECT IN READ-ONLY MODE EXPECTED AT RHS.') + IPMAC2=KENTRY(1) + IPFLUX=KENTRY(2) + CALL LCMGTC(IPFLUX,'SIGNATURE',12,HSIGN) + TEXT12=HENTRY(2) + IF(HSIGN.NE.'L_FLUX') THEN + CALL XABORT('OUT: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_FLUX EXPECTED.') + ENDIF + HSIGN='L_MACROLIB' + CALL LCMPTC(IPMAC2,'SIGNATURE',12,HSIGN) + CALL LCMPTC(IPMAC2,'LINK.FLUX',12,TEXT12) +*---- +* RECOVER IPGEOM, IPMAC1 AND IPTRK POINTERS. +*---- + CALL LCMGTC(IPFLUX,'LINK.TRACK',12,TEXT12) + DO 10 I=1,NENTRY + IF(HENTRY(I).EQ.TEXT12) THEN + IPTRK=KENTRY(I) + CALL LCMGTC(IPTRK,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_TRACK') THEN + TEXT12=HENTRY(I) + CALL XABORT('OUT: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_TRACK EXPECTED.') + ENDIF + GO TO 20 + ENDIF + 10 CONTINUE + CALL XABORT('OUT: UNABLE TO FIND A POINTER TO L_TRACK.') + 20 CALL LCMGTC(IPFLUX,'LINK.MACRO',12,TEXT12) + DO 50 I=1,NENTRY + IF(HENTRY(I).EQ.TEXT12) THEN + IPMAC1=KENTRY(I) + CALL LCMGTC(IPMAC1,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_MACROLIB') THEN + TEXT12=HENTRY(I) + CALL XABORT('OUT: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_MACROLIB EXPECTED.') + ENDIF + GO TO 60 + ENDIF + 50 CONTINUE + CALL XABORT('OUT: UNABLE TO FIND A POINTER TO L_MACROLIB.') + 60 DO 70 I=1,NENTRY + CALL LCMLEN(KENTRY(I),'SIGNATURE',ILONG,ITYLCM) + IF(ILONG.NE.0) THEN + CALL LCMGTC(KENTRY(I),'SIGNATURE',12,HSIGN) + IF(HSIGN.EQ.'L_GEOM') THEN + IPGEOM=KENTRY(I) + GO TO 80 + ENDIF + ENDIF + 70 CONTINUE + CALL XABORT('OUT: UNABLE TO FIND A POINTER TO L_GEOM.') + 80 CALL LCMGET(IPMAC1,'STATE-VECTOR',IGP) + NGRP=IGP(1) + NBMIX=IGP(2) + NL=IGP(3) + NBFIS=IGP(4) + NALBP=IGP(8) +*---- +* FIND TYPE OF TRACKING. +*---- + CALL LCMGTC(IPTRK,'TRACK-TYPE',12,HTRACK) +*---- +* RECOVER GENERAL TRACKING INFORMATION. +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',IGP) + NEL=IGP(1) + NUN=IGP(2) + IF(HTRACK.EQ.'BIVAC') THEN + IELEM=IGP(8) + ICOL=IGP(9) + IBFP=0 + ELSE IF(HTRACK.EQ.'TRIVAC') THEN + IELEM=IGP(9) + ICOL=IGP(10) + IBFP=0 + ELSE IF(HTRACK.EQ.'SN') THEN + IELEM=IGP(8) + ICOL=0 + IBFP=IGP(31) + ELSE + ICOL=0 + IBFP=0 + ENDIF + MAXNEL=NEL + CALL LCMLEN(IPTRK,'KEYFLX',LKFL,ITYLCM) + ALLOCATE(MAT(NEL),VOL(NEL),IDL(LKFL)) + CALL LCMGET(IPTRK,'MATCOD',MAT) + CALL LCMGET(IPTRK,'VOLUME',VOL) + CALL LCMGET(IPTRK,'KEYFLX',IDL) + CALL LCMLEN(IPTRK,'TITLE',LENGT,ITYLCM) + IF(LENGT.GT.0) THEN + CALL LCMGTC(IPTRK,'TITLE',72,TITLE) + CALL LCMPTC(IPMAC2,'TITLE',72,TITLE) + ELSE + TITLE='*** NO TITLE PROVIDED ***' + ENDIF +*---- +* EDITION. +*---- + CALL OUTDRV(IPGEOM,IPMAC1,IPFLUX,IPMAC2,MAXNEL,NBMIX,NL, + 1 NBFIS,NGRP,NEL,NUN,NALBP,HTRACK,IELEM,ICOL,MAT,VOL,IDL, + 2 TITLE,IBFP) +*---- +* RELEASE GENERAL TRACKING INFORMATION. +*---- + DEALLOCATE(IDL,VOL,MAT) + RETURN + END |