summaryrefslogtreecommitdiff
path: root/Ganlib/src/MSTR.f
diff options
context:
space:
mode:
Diffstat (limited to 'Ganlib/src/MSTR.f')
-rw-r--r--Ganlib/src/MSTR.f222
1 files changed, 222 insertions, 0 deletions
diff --git a/Ganlib/src/MSTR.f b/Ganlib/src/MSTR.f
new file mode 100644
index 0000000..567369b
--- /dev/null
+++ b/Ganlib/src/MSTR.f
@@ -0,0 +1,222 @@
+*DECK MSTR
+ SUBROUTINE MSTR(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Manage user-defined structures.
+*
+*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/output
+* NENTRY number of LCM objects or files used by the operator.
+* HENTRY name of each LCM object or file:
+* HENTRY(1): modification type(VECTOR);
+* HENTRY(2): read-only type(VECTOR).
+* 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
+ CHARACTER HENTRY(NENTRY)*12
+ INTEGER IENTRY(NENTRY),JENTRY(NENTRY)
+ TYPE(C_PTR) KENTRY(NENTRY)
+*----
+* LOCAL VARIABLES
+*----
+ INTEGER I,ACSTR,TYSTR,ACSTRO,TYSTRO,ACSTR2,TYSTR2
+ INTEGER, PARAMETER :: IOUT=6
+ INTEGER, PARAMETER :: NSTATE=40
+ INTEGER INDIC,NITMA,ISTATE(NSTATE),IPRINT,NBLOCK,ILEN,ITYP,NBDIR
+ REAL FLOTT
+ DOUBLE PRECISION DFLOTT
+ CHARACTER TEXT4*4,NAME*12,PATH*72,DIRS(37)*12,NAME2*12,TEXT12*12
+ LOGICAL ROOT
+ TYPE(C_PTR) IPSTR,IPSTRO,IPSTR2
+ CHARACTER(LEN=12), ALLOCATABLE, DIMENSION(:) :: BLNAM
+ INTEGER, ALLOCATABLE, DIMENSION(:) :: BLTYP,BLLEN
+*----
+* PARAMETER VALIDATION
+*----
+ IF(NENTRY.LT.1)
+ 1 CALL XABORT('MSTR: AT LEAST ONE PARAMETER EXPECTED.')
+ DO I=1,NENTRY
+ IF(IENTRY(I).GT.2)
+ 1 CALL XABORT('MSTR: LINKED LIST OR XSM EXPECTED.')
+ ENDDO
+*----
+* CREATE STATE-VECTOR/SIGNATURE FOR STRUCTURES IN CREATION MODE
+* VERIFY IF IT EXISTS FOR STRUCTURES IN MODIFICATION MODE
+*----
+ DO I=1,NENTRY
+ ACSTR=JENTRY(I)
+ IPSTR=KENTRY(I)
+ IF (ACSTR.EQ.0) THEN
+* THE STRUCTURE IS CREATED:
+* ASSIGN IT A DEFAULT SIGNATURE AND A STATE-VECTOR
+ NAME='VECTOR'
+ CALL LCMPTC(IPSTR,'SIGNATURE',12,NAME)
+ ISTATE(:NSTATE)=0
+ CALL LCMPUT(IPSTR,'STATE-VECTOR',NSTATE,1,ISTATE)
+ ELSEIF (ACSTR.EQ.1) THEN
+ CALL LCMLEN(IPSTR,'SIGNATURE',ILEN,ITYP)
+ IF ((ILEN.NE.3).OR.(ITYP.NE.3))
+ 1 CALL XABORT('MSTR: INVALID SIGNATURE FOR '//HENTRY(I)
+ 2 //'.')
+ CALL LCMLEN(IPSTR,'STATE-VECTOR',ILEN,ITYP)
+ IF ((ILEN.NE.40).OR.(ITYP.NE.1))
+ 1 CALL XABORT('MSTR: INVALID STATE-VECTOR FOR '//HENTRY(I)
+ 2 //'.')
+ ENDIF
+ ENDDO
+*---
+* PROCESS USER'S INPUT
+*---
+ IPRINT=0
+ ACSTR=JENTRY(1)
+ TYSTR=IENTRY(1)
+ IPSTR=KENTRY(1)
+ ACSTR2=ACSTR
+ TYSTR2=TYSTR
+ IPSTR2=IPSTR
+ 50 CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT)
+ IF(INDIC.EQ.10) GO TO 60
+ IF(INDIC.NE.3) CALL XABORT('MSTR: CHARACTER DATA EXPECTED(1).')
+ IF(TEXT4.EQ.'EDIT') THEN
+* MODULE EDITION LEVEL
+ CALL REDGET(INDIC,IPRINT,FLOTT,TEXT4,DFLOTT)
+ IF(INDIC.NE.1) CALL XABORT('MSTR: INTEGER DATA EXPECTED(1).')
+ ELSEIF(TEXT4.EQ.'TYPE') THEN
+* USER DEFINED TYPE FOR THE STRUCTURE
+ CALL REDGET(INDIC,NITMA,FLOTT,PATH,DFLOTT)
+ IF(INDIC.NE.3)
+ 1 CALL XABORT('MSTR: CHARACTER DATA EXPECTED(2).')
+ CALL MSTANP(NENTRY,IENTRY,JENTRY,KENTRY,PATH,IPSTR,
+ 1 ACSTR,TYSTR,NBDIR,DIRS,ROOT)
+ IF (NBDIR.NE.1) CALL XABORT('MSTR: INVALID TYPE ENTRY.')
+ CALL LCMPTC(IPSTR,'SIGNATURE',12,DIRS(1))
+ ELSEIF((TEXT4.EQ.'PUT').OR.
+ 1 (TEXT4.EQ.'GET').OR.
+ 2 (TEXT4.EQ.'CP')) THEN
+* PUT, GET OR CP ACTION
+ CALL REDGET(INDIC,NELEM,FLOTT,TEXT12,DFLOTT)
+* NUMBER OF ELEMENTS
+ IF(INDIC.NE.1) CALL XABORT('MSTR: INTEGER DATA EXPECTED(2).')
+ IBEG=1
+ IEND=NELEM
+ IINC=1
+ CALL REDGET(INDIC,NITMA,FLOTT,PATH,DFLOTT)
+ IF(INDIC.EQ.1) THEN
+* STARTING INDEX
+ IBEG=NITMA
+ CALL REDGET(INDIC,NITMA,FLOTT,PATH,DFLOTT)
+ IF(INDIC.EQ.1) THEN
+* INCREMENT
+ IINC=NITMA
+ ELSE
+ GOTO 10
+ ENDIF
+ CALL REDGET(INDIC,NITMA,FLOTT,PATH,DFLOTT)
+ ENDIF
+ 10 CONTINUE
+ IEND=IBEG+(NELEM-1)*IINC
+ IF (INDIC.NE.3)
+ 1 CALL XABORT('MSTR: CHARACTER DATA EXPECTED(3).')
+ IPSTRO=IPSTR
+ ACSTRO=ACSTR
+ TYSTRO=TYSTR
+* ANALYSE USER'S PATH
+ CALL MSTANP(NENTRY,IENTRY,JENTRY,KENTRY,PATH,IPSTR,
+ 1 ACSTR,TYSTR,NBDIR,DIRS,ROOT)
+* GO TO REQUESTED DIRECTORY
+ IF (NBDIR.GT.1) THEN
+ CALL MSTMOV(IPSTR,ACSTR,IPRINT,NBDIR-1,DIRS,ROOT)
+ ENDIF
+ NAME=DIRS(NBDIR)
+ IF (TEXT4.EQ.'PUT') THEN
+* CREATING OR UPDATING DATA IN A BLOCK
+ IF (ACSTR.EQ.2)
+ 1 CALL XABORT('MSTR: PUT NOT PERMITTED IN READ-ONLY MODE')
+ CALL LCMGET(IPSTR,'STATE-VECTOR',ISTATE)
+ NBLOCK=ISTATE(40)
+ ALLOCATE(BLNAM(NBLOCK+1),BLTYP(NBLOCK+1),BLLEN(NBLOCK+1))
+ IF (NBLOCK.GT.0) THEN
+ CALL LCMGTC(IPSTR,'REC-NAMES',12,NBLOCK+1,BLNAM)
+ CALL LCMGET(IPSTR,'REC-TYPES',BLTYP)
+ CALL LCMGET(IPSTR,'REC-LENGTHS',BLLEN)
+ ENDIF
+ CALL MSTPUT(IPSTR,IPRINT,IBEG,IEND,IINC,NAME,NBLOCK,BLNAM,
+ 1 BLTYP,BLLEN)
+ DEALLOCATE(BLLEN,BLTYP,BLNAM)
+ ELSEIF(TEXT4.EQ.'GET') THEN
+* RETRIEVING DATA FROM A BLOCK
+ CALL MSTGET(IPSTR,IPRINT,IBEG,IEND,IINC,NAME)
+ ELSEIF(TEXT4.EQ.'CP') THEN
+* COPYING A BLOCK FROM ONE PLACE TO ANOTHER
+ CALL REDGET(INDIC,NITMA,FLOTT,PATH,DFLOTT)
+ IF (INDIC.NE.3)
+ 1 CALL XABORT('MSTR: CHARACTER DATA EXPECTED(4).')
+* ANALYSE USER'S PATH
+ CALL MSTANP(NENTRY,IENTRY,JENTRY,KENTRY,PATH,IPSTR2,
+ 1 ACSTR2,TYSTR2,NBDIR,DIRS,ROOT)
+ IF (ACSTR2.EQ.2)
+ 1 CALL XABORT('MSTR: CP NOT PERMITTED IN READ-ONLY MODE')
+* GO TO REQUESTED DIRECTORY
+ IF (NBDIR.GT.1) THEN
+ CALL MSTMOV(IPSTR2,ACSTR2,IPRINT,NBDIR-1,DIRS,ROOT)
+ ENDIF
+ NAME2=DIRS(NBDIR)
+ CALL LCMGET(IPSTR2,'STATE-VECTOR',ISTATE)
+ NBLOCK=ISTATE(40)
+ ALLOCATE(BLNAM(NBLOCK+1),BLTYP(NBLOCK+1),BLLEN(NBLOCK+1))
+ IF (NBLOCK.GT.0) THEN
+ CALL LCMGTC(IPSTR2,'REC-NAMES',12,NBLOCK+1,BLNAM)
+ CALL LCMGET(IPSTR2,'REC-TYPES',BLTYP)
+ CALL LCMGET(IPSTR2,'REC-LENGTHS',BLLEN)
+ ENDIF
+ CALL MSTCPB(IPSTR,IPSTR2,IPRINT,IBEG,IEND,IINC,NAME,NAME2,
+ 1 NBLOCK,BLNAM,BLTYP,BLLEN)
+ DEALLOCATE(BLLEN,BLTYP,BLNAM)
+ ENDIF
+ IPSTR=IPSTRO
+ ACSTR=ACSTRO
+ TYSTR=TYSTRO
+ ELSEIF(TEXT4.EQ.'CD') THEN
+* CHANGING DIRECTORY
+ CALL REDGET(INDIC,NITMA,FLOTT,PATH,DFLOTT)
+ IF(INDIC.NE.3)
+ 1 CALL XABORT('MSTR: CHARACTER DATA EXPECTED(5).')
+* ANALYSE USER'S PATH
+ CALL MSTANP(NENTRY,IENTRY,JENTRY,KENTRY,PATH,IPSTR,
+ 1 ACSTR,TYSTR,NBDIR,DIRS,ROOT)
+* GO TO REQUESTED DIRECTORY
+ CALL MSTMOV(IPSTR,ACSTR,IPRINT,NBDIR,DIRS,ROOT)
+ ELSEIF(TEXT4.EQ.';') THEN
+ GOTO 60
+ ELSE
+ CALL XABORT('MSTR: '//TEXT4//' IS AN INVALID KEY WORD.')
+ ENDIF
+ GOTO 50
+*
+ 60 CONTINUE
+*
+ RETURN
+ END
generated by cgit v1.2.3 (git 2.46.0) at 2026-02-16 11:15:06 +0000