Initial commit from Polytechnique Montreal

1 files changed, 84 insertions, 0 deletions

diff --git a/Trivac/src/GEOD.f b/Trivac/src/GEOD.f
new file mode 100755
index 0000000..497760f
--- /dev/null
+++ b/Trivac/src/GEOD.f
@@ -0,0 +1,84 @@
+*DECK GEO
+      SUBROUTINE GEOD(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Geometry definition operator.
+*
+*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_GEOM).
+*         HENTRY(2): optional 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.
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      INTEGER      NENTRY,IENTRY(NENTRY),JENTRY(NENTRY)
+      TYPE(C_PTR)  KENTRY(NENTRY)
+      CHARACTER    HENTRY(NENTRY)*12
+*----
+*  LOCAL VARIABLES
+*----
+      CHARACTER    TEXT12*12,TEXT13*12
+      TYPE(C_PTR)  IPLIST
+*----
+*  PARAMETER VALIDATION
+*----
+      IF(NENTRY.EQ.0) CALL XABORT('GEOD: PARAMETER EXPECTED.')
+      IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) CALL XABORT('GEOD: LCM'
+     1 //' OBJECT EXPECTED AT LHS.')
+      IF((JENTRY(1).NE.0).AND.(JENTRY(1).NE.1)) CALL XABORT('GEOD: CRE'
+     1 //'ATE OR MODIFICATION MODE EXPECTED.')
+      ITYPE=JENTRY(1)
+      IPLIST=KENTRY(1)
+*
+      IMPX=1
+      IF((ITYPE.EQ.0).AND.(NENTRY.GT.1)) THEN
+*        CREATE A NEW GEOMETRY BASED ON AN EXISTING ONE.
+         IF(JENTRY(2).NE.2) CALL XABORT('GEOD: RHS GEOMETRY EXPECTED O'
+     1   //'PEN IN READ-ONLY MODE.')
+         IF((IENTRY(2).NE.1).AND.(IENTRY(2).NE.2)) CALL XABORT('GEOD: '
+     1   //'LCM OBJECT EXPECTED AT RHS.')
+         CALL LCMGTC(KENTRY(2),'SIGNATURE',12,TEXT12)
+         IF(TEXT12.NE.'L_GEOM') THEN
+            TEXT13=HENTRY(2)
+            CALL XABORT('GEOD: SIGNATURE OF '//TEXT13//' IS '//TEXT12//
+     1      '. L_GEOM EXPECTED(1).')
+         ENDIF
+         CALL LCMEQU(KENTRY(2),IPLIST)
+      ELSE IF(ITYPE.EQ.1) THEN
+*        MODIFY AN EXISTING GEOMETRY USING THE SAME NAME.
+         CALL LCMGTC(IPLIST,'SIGNATURE',12,TEXT12)
+         IF(TEXT12.NE.'L_GEOM') THEN
+            TEXT13=HENTRY(1)
+            CALL XABORT('GEOD: SIGNATURE OF '//TEXT13//' IS '//TEXT12//
+     1      '. L_GEOM EXPECTED(2).')
+         ENDIF
+      ENDIF
+*
+      TEXT12='/'
+      CALL GEODIN(TEXT12,IPLIST,1,IMPX,MAXMIX)
+      RETURN
+      END