Initial commit from Polytechnique Montreal

1 files changed, 106 insertions, 0 deletions

diff --git a/Ganlib/src/MSTCDI.f b/Ganlib/src/MSTCDI.f
new file mode 100644
index 0000000..5094911
--- /dev/null
+++ b/Ganlib/src/MSTCDI.f
@@ -0,0 +1,106 @@
+*DECK MSTCDI
+      SUBROUTINE MSTCDI(IPSTR,ACSTR,IPRINT,NBLOCK,MYDIR,BLNAM,BLTYP,
+     1                  BLLEN)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Create a new directory and move in a structure according to a defined
+* directory name.
+*
+*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): R. Le Tellier
+*
+*Parameters: input
+* ACSTR   structure access.
+* IPRINT  level of print index.
+* NBLOCK  number of existing block in the directory.
+* MYDIR   name of the directory to be created/moved in.
+* BLNAM   names of these blocks.
+* BLTYP   types of these blocks.
+* BLLEN   lengths of these blocks.
+*
+*Parameters: input/output
+* IPSTR   entering/leaving directory address.
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+      IMPLICIT NONE
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      TYPE(C_PTR) IPSTR
+      INTEGER ACSTR,IPRINT,NBLOCK,BLTYP(NBLOCK+1),BLLEN(NBLOCK+1)
+      CHARACTER(LEN=12) BLNAM(NBLOCK+1)
+      CHARACTER*12 MYDIR
+*----
+*  LOCAL VARIABLES
+*----
+      INTEGER IOUT,NSTATE
+      PARAMETER (IOUT=6,NSTATE=40)
+      INTEGER ISTATE(NSTATE),JJ,ILEN,ITYP
+      LOGICAL EXIST
+*----      
+* PERFORM CD RELATED ACTIONS
+*----
+      IF (MYDIR.EQ.'..') THEN
+*     GOING TO FATHER DIR
+         IF (IPRINT.GT.2) WRITE(IOUT,*) 'MSTCDI: GOING TO FATHER DIR'
+         CALL LCMSIX(IPSTR,' ',2)
+      ELSE
+*     GOING TO SON DIR
+         EXIST=.FALSE.
+         IF (NBLOCK.NE.0) THEN
+*        IS THIS SON DIR ALREADY PART OF THE STRUCTURE ?
+            DO JJ=1,NBLOCK
+               IF(BLNAM(JJ).EQ.MYDIR) THEN
+                  IF (BLLEN(JJ).NE.-1) CALL XABORT('MSTCDI: '//MYDIR//
+     1            ' IS AN EXISTING BLOCK.')
+                  EXIST=.TRUE.
+                  GOTO 10
+               ENDIF
+            ENDDO
+ 10         CONTINUE
+         ENDIF
+         IF (EXIST) THEN
+*        YES: 
+            IF (IPRINT.GT.2)
+     1         WRITE(IOUT,*) 'MSTCDI: ENTERING EXISTING DIR '//MYDIR
+         ELSE
+*        NO:
+            CALL LCMLEN(IPSTR,MYDIR,ILEN,ITYP)
+            IF (ILEN.NE.0) THEN
+*              IT IS ASSUMED THAT THIS IS AN EXTERNAL STRUCTURE FROM WHICH INFORMATION CAN BE RETRIEVED
+               EXIST=.TRUE.
+               GOTO 20
+            ENDIF
+            IF (ACSTR.EQ.2)
+     1        CALL XABORT('MSTCDI: CANNOT CREATE DIR IN READ-ONLY MODE')
+            IF (IPRINT.GT.2)
+     1         WRITE(IOUT,*) 'MSTCDI: CREATING DIR '//MYDIR
+            CALL LCMGET(IPSTR,'STATE-VECTOR',ISTATE)
+            ISTATE(40)=ISTATE(40)+1
+            BLNAM(NBLOCK+1)=MYDIR
+            BLTYP(NBLOCK+1)=0
+            BLLEN(NBLOCK+1)=-1
+            CALL LCMPUT(IPSTR,'STATE-VECTOR',NSTATE,1,ISTATE)
+            CALL LCMPTC(IPSTR,'REC-NAMES',12,NBLOCK+1,BLNAM)
+            CALL LCMPUT(IPSTR,'REC-TYPES',(NBLOCK+1),1,BLTYP)
+            CALL LCMPUT(IPSTR,'REC-LENGTHS',(NBLOCK+1),1,BLLEN)
+         ENDIF
+ 20      CALL LCMSIX(IPSTR,MYDIR,1)
+         IF (.NOT.EXIST) THEN
+            ISTATE(:NSTATE)=0
+            CALL LCMPUT(IPSTR,'STATE-VECTOR',NSTATE,1,ISTATE)
+         ENDIF
+      ENDIF
+      
+      RETURN
+      END