From 7dfcc480ba1e19bd3232349fc733caef94034292 Mon Sep 17 00:00:00 2001 From: stainer_t Date: Mon, 8 Sep 2025 13:48:49 +0200 Subject: Initial commit from Polytechnique Montreal --- Dragon/src/NXTLDC.f | 104 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 104 insertions(+) create mode 100644 Dragon/src/NXTLDC.f (limited to 'Dragon/src/NXTLDC.f') diff --git a/Dragon/src/NXTLDC.f b/Dragon/src/NXTLDC.f new file mode 100644 index 0000000..9f2c6c5 --- /dev/null +++ b/Dragon/src/NXTLDC.f @@ -0,0 +1,104 @@ +*DECK NXTLDC + SUBROUTINE NXTLDC(IPTRK,MAXMSH,ICEL,IDIRC,MESHC,NSURC,NREGC, + 1 NTPIN,DCMESH,INDEX,IDREG,IDSUR,ITPIN,DRAPIN) +*----------------------------------------------------------------------- +* +*Purpose: +* Load cell contents. +* +*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): R. Le Tellier +* +*Parameters: input +* IPTRK pointer to the TRACKING data structure. +* MAXMSH maximum number of elements in MESH array. +* ICEL requested cell index. +* +*Parameters: output +* IDIRC cylinders orientation. +* MESHC cell meshes size. +* NSURC number of surfaces for the cell. +* NREGC number of regions for the cell. +* NTPIN number of pins within the cell. +* DCMESH cell meshing vector. +* INDEX cell index vector. +* IDREG region index array. +* IDSUR surface index array. +* ITPIN pin integer descriptor. +* DRAPIN pin double descriptor. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK + INTEGER MAXMSH,ICEL,IDIRC,MESHC(4),NSURC,NREGC,NTPIN, + 1 INDEX(5,-NSURC:NREGC),IDREG(NREGC),IDSUR(NSURC),ITPIN(3,NTPIN) + DOUBLE PRECISION DCMESH(-1:MAXMSH,4),DRAPIN(-1:4,NTPIN) +*---- +* LOCAL VARIABLES +*---- + INTEGER NSTATE,IOUT + PARAMETER(NSTATE=40,IOUT=6) + INTEGER ESTATE(NSTATE) + INTEGER IDIR,ITYPG + CHARACTER NAMCEL*9,NAMREC*12 + CHARACTER CDIR(4)*1 + DATA CDIR /'X','Y','Z','R'/ +*---- +* LOAD CELL RECORDS +*---- + WRITE(NAMCEL,'(A1,I8.8)') 'C',ICEL + NAMREC=NAMCEL//'DIM' + ESTATE(:NSTATE)=0 + CALL LCMGET(IPTRK,NAMREC,ESTATE) + ITYPG=ESTATE(1) + MESHC(1)=ESTATE(3) + MESHC(2)=ESTATE(4) + MESHC(3)=ESTATE(5) + MESHC(4)=ESTATE(2) + NREGC=ESTATE(8) + NSURC=ESTATE(9) + NTPIN=ESTATE(18) + NAMREC=NAMCEL//'RID' + CALL LCMGET(IPTRK,NAMREC,IDREG) + NAMREC=NAMCEL//'SID' + CALL LCMGET(IPTRK,NAMREC,IDSUR) + NAMREC=NAMCEL//'VSI' + CALL LCMGET(IPTRK,NAMREC,INDEX) + DO IDIR=1,4 + NAMREC=NAMCEL//'SM'//CDIR(IDIR) + IF(MESHC(IDIR).GT.0) THEN + CALL LCMGET(IPTRK,NAMREC,DCMESH(-1,IDIR)) + ENDIF + ENDDO + IF(NTPIN.GT.0) THEN + NAMREC=NAMCEL//'PIN' + CALL LCMGET(IPTRK,NAMREC,DRAPIN) + NAMREC=NAMCEL//'PNT' + CALL LCMGET(IPTRK,NAMREC,ITPIN) + ENDIF + IF(ITYPG .EQ. 20 .OR. ITYPG .EQ. 21 .OR. + > ITYPG .EQ. 22 .OR. ITYPG .EQ. 23) THEN + IF(ITYPG .EQ. 21 ) THEN + IDIRC=1 + ELSE IF(ITYPG .EQ. 22) THEN + IDIRC=2 + ELSE + IDIRC=3 + ENDIF + ELSE + IDIRC=0 + ENDIF +* + RETURN + END -- cgit v1.2.3