Initial commit from Polytechnique Montreal

1 files changed, 197 insertions, 0 deletions

diff --git a/Ganlib/src/LCMULT.f b/Ganlib/src/LCMULT.f
new file mode 100644
index 0000000..aa7f4b4
--- /dev/null
+++ b/Ganlib/src/LCMULT.f
@@ -0,0 +1,197 @@
+*DECK LCMULT
+      SUBROUTINE LCMULT(IPLIST,FLOTT)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Multiply the floating point information contained in the active
+* directory of a table or XSM file by a real number.
+*
+*Copyright:
+* Copyright (C) 1993 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
+* IPLIS1  address of the table or handle to the XSM file.
+* FLOTT   real number.
+*
+*Parameters: output
+* IPLIS1  address of the table or handle to the XSM file.
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      TYPE(C_PTR) IPLIST
+      REAL FLOTT
+*----
+*  LOCAL VARIABLES
+*----
+      PARAMETER (MAXLEV=50)
+      TYPE(C_PTR) KDATA(MAXLEV)
+      CHARACTER NAMT*12,HSMG*131,MYNAME*12,NAMLCM*12,PATH(MAXLEV)*12,
+     1 FIRST(MAXLEV)*12
+      LOGICAL EMPTY,LCM
+      INTEGER IVEC(MAXLEV),KJLON(MAXLEV),IGO(MAXLEV)
+      TYPE(C_PTR) :: PT_DATA
+      REAL, POINTER :: RRR(:)
+      DOUBLE PRECISION, POINTER :: DDD(:)
+      COMPLEX, POINTER :: CCC(:)
+*
+      CALL LCMVAL(IPLIST,' ')
+      ILEV=1
+      KDATA(1)=IPLIST
+      KJLON(1)=-1
+      IVEC(1)=1
+      IGO(1)=5
+*
+* ASSOCIATIVE TABLE.
+   10 CALL LCMINF(IPLIST,MYNAME,NAMLCM,EMPTY,ILONG,LCM)
+      IF(EMPTY) GO TO (100,100,240,240,250),IGO(ILEV)
+      NAMT=' '
+      CALL LCMNXT(IPLIST,NAMT)
+*
+      FIRST(ILEV)=NAMT
+   15 CALL LCMLEN(IPLIST,NAMT,ILON1,ITY1)
+      IF(ITY1.EQ.0) THEN
+*        ASSOCIATIVE TABLE DATA.
+         ILEV=ILEV+1
+         IF(ILEV.GT.MAXLEV) THEN
+            WRITE(HSMG,'(2A,A12,A)') 'LCMULT: TOO MANY DIRECTORY ',
+     1      'LEVELS ON ''',MYNAME,'''(1).'
+            CALL XABORT(HSMG)
+         ENDIF
+         KJLON(ILEV)=-1
+         KDATA(ILEV)=LCMGID(IPLIST,NAMT)
+         PATH(ILEV)=NAMT
+         IPLIST=KDATA(ILEV)
+         IVEC(ILEV)=1
+         IGO(ILEV)=1
+         GO TO 10
+      ELSE IF(ITY1.EQ.10) THEN
+*        LIST DATA.
+         ILEV=ILEV+1
+         IF(ILEV.GT.MAXLEV) THEN
+            WRITE(HSMG,'(2A,A12,A)') 'LCMULT: TOO MANY DIRECTORY ',
+     1      'LEVELS ON ''',MYNAME,'''(2).'
+            CALL XABORT(HSMG)
+         ENDIF
+         KJLON(ILEV)=ILON1
+         KDATA(ILEV)=LCMGID(IPLIST,NAMT)
+         PATH(ILEV)=NAMT
+         IPLIST=KDATA(ILEV)
+         IVEC(ILEV)=0
+         IGO(ILEV)=2
+         GO TO 190
+      ELSE IF(ITY1.EQ.2) THEN
+*        SINGLE PRECISION DATA.
+         CALL LCMGPD(IPLIST,NAMT,PT_DATA)
+         CALL C_F_POINTER(PT_DATA, RRR, (/ ILON1 /))
+         DO 70 I=1,ILON1
+         RRR(I)=FLOTT*RRR(I)
+   70    CONTINUE
+         CALL LCMPPD(IPLIST,NAMT,ILON1,ITY1,PT_DATA)
+      ELSE IF(ITY1.EQ.4) THEN
+*        DOUBLE PRECISION DATA.
+         CALL LCMGPD(IPLIST,NAMT,PT_DATA)
+         CALL C_F_POINTER(PT_DATA, DDD, (/ ILON1 /))
+         DO 80 I=1,ILON1
+         DDD(I)=FLOTT*DDD(I)
+   80    CONTINUE
+         CALL LCMPPD(IPLIST,NAMT,ILON1,ITY1,PT_DATA)
+      ELSE IF(ITY1.EQ.6) THEN
+*        COMPLEX DATA.
+         CALL LCMGPD(IPLIST,NAMT,PT_DATA)
+         CALL C_F_POINTER(PT_DATA, CCC, (/ ILON1 /))
+         DO 90 I=1,ILON1
+         CCC(I)=FLOTT*CCC(I)
+   90    CONTINUE
+         CALL LCMPPD(IPLIST,NAMT,ILON1,ITY1,PT_DATA)
+      ENDIF
+      CALL LCMNXT(IPLIST,NAMT)
+      IF(NAMT.NE.FIRST(ILEV)) GO TO 15
+      GO TO (100,100,240,240,250),IGO(ILEV)
+*
+  100 NAMT=PATH(ILEV)
+      ILEV=ILEV-1
+      IPLIST=KDATA(ILEV)
+      CALL LCMNXT(IPLIST,NAMT)
+      IF(NAMT.NE.FIRST(ILEV)) GO TO 15
+      GO TO (100,100,240,240,250),IGO(ILEV)
+*
+* LIST.
+  190 IVEC(ILEV)=IVEC(ILEV)+1
+      IF(IVEC(ILEV).GT.KJLON(ILEV)) THEN
+         GO TO (100,100,240,240,250),IGO(ILEV)
+      ENDIF
+      CALL LCMLEL(KDATA(ILEV),IVEC(ILEV),ILON1,ITY1)
+      IF((ILON1.NE.0).AND.(ITY1.EQ.0)) THEN
+*        ASSOCIATIVE TABLE DATA.
+         ILEV=ILEV+1
+         IF(ILEV.GT.MAXLEV) THEN
+            WRITE(HSMG,'(2A,A12,A)') 'LCMULT: TOO MANY DIRECTORY ',
+     1      'LEVELS ON ''',MYNAME,'''(3).'
+            CALL XABORT(HSMG)
+         ENDIF
+         KJLON(ILEV)=-1
+         KDATA(ILEV)=LCMGIL(IPLIST,IVEC(ILEV-1))
+         IPLIST=KDATA(ILEV)
+         IVEC(ILEV)=1
+         IGO(ILEV)=3
+         GO TO 10
+      ELSE IF((ILON1.NE.0).AND.(ITY1.EQ.10)) THEN
+*        LIST DATA.
+         ILEV=ILEV+1
+         IF(ILEV.GT.MAXLEV) THEN
+            WRITE(HSMG,'(2A,A12,A)') 'LCMULT: TOO MANY DIRECTORY ',
+     1      'LEVELS ON ''',MYNAME,'''(4).'
+            CALL XABORT(HSMG)
+         ENDIF
+         KJLON(ILEV)=ILON1
+         KDATA(ILEV)=LCMGIL(IPLIST,IVEC(ILEV-1))
+         IPLIST=KDATA(ILEV)
+         IVEC(ILEV)=0
+         IGO(ILEV)=4
+         GO TO 190
+      ELSE IF((ILON1.NE.0).AND.(ITY1.LE.6)) THEN
+         IF((ITY1.EQ.2).OR.(ITY1.EQ.6)) THEN
+*           SINGLE PRECISION DATA.
+            CALL LCMGPL(IPLIST,IVEC(ILEV),PT_DATA)
+            CALL C_F_POINTER(PT_DATA, RRR, (/ ILON1 /))
+            DO 210 I=1,ILON1
+            RRR(I)=FLOTT*RRR(I)
+  210       CONTINUE
+            CALL LCMPPL(IPLIST,IVEC(ILEV),ILON1,ITY1,PT_DATA)
+         ELSE IF(ITY1.EQ.4) THEN
+*           DOUBLE PRECISION DATA.
+            CALL LCMGPL(IPLIST,IVEC(ILEV),PT_DATA)
+            CALL C_F_POINTER(PT_DATA, DDD, (/ ILON1 /))
+            DO 220 I=1,ILON1
+            DDD(I)=FLOTT*DDD(I)
+  220       CONTINUE
+            CALL LCMPPL(IPLIST,IVEC(ILEV),ILON1,ITY1,PT_DATA)
+         ELSE IF(ITY1.EQ.6) THEN
+*           COMPLEX DATA.
+            CALL LCMGPL(IPLIST,IVEC(ILEV),PT_DATA)
+            CALL C_F_POINTER(PT_DATA, CCC, (/ ILON1 /))
+            DO 230 I=1,ILON1
+            CCC(I)=FLOTT*CCC(I)
+  230       CONTINUE
+            CALL LCMPPL(IPLIST,IVEC(ILEV),ILON1,ITY1,PT_DATA)
+         ENDIF
+      ENDIF
+      GO TO 190
+*
+  240 ILEV=ILEV-1
+      IPLIST=KDATA(ILEV)
+      GO TO 190
+*
+  250 RETURN
+      END