Initial commit from Polytechnique Montreal

1 files changed, 110 insertions, 0 deletions

diff --git a/Trivac/src/MTBLD.f b/Trivac/src/MTBLD.f
new file mode 100755
index 0000000..a247d91
--- /dev/null
+++ b/Trivac/src/MTBLD.f
@@ -0,0 +1,110 @@
+*DECK MTBLD
+      SUBROUTINE MTBLD(HNAME,IPTRK,IPSYS,ITY)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* LCM driver for VECBLD.
+*
+*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
+* HNAME   name of the matrix. HNAME(:1) is 'W ', 'X ', 'Y', or 'Z'.
+*         In case of a Thomas-Raviart basis, can also be equal to 'WA',
+*        'XA', 'YA' or 'ZA'.
+* IPTRK   L_TRACK pointer to the tracking information.
+* IPSYS   L_SYSTEM pointer to system matrices.
+* ITY     type of processing:
+*         =1 gather back; =2 scatter forth;
+*         =3 scatter forth and store the diagonal elements.
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      TYPE(C_PTR) IPTRK,IPSYS
+      CHARACTER HNAME*(*)
+      INTEGER ITY
+*----
+*  LOCAL VARIABLES
+*----
+      PARAMETER (NSTATE=40)
+      CHARACTER TEXT12*12,HSMG*131,HCHAR*1
+      INTEGER ITP(NSTATE)
+      REAL DUMMY(1)
+      TYPE(C_PTR) ASS_PTR,ASSV_PTR
+      INTEGER, DIMENSION(:), ALLOCATABLE :: MU,MUV,IPV,LBL
+      REAL, DIMENSION(:), POINTER :: ASS,ASSV
+      REAL, DIMENSION(:), ALLOCATABLE :: DGV
+*----
+*  RECOVER TRACKING INFORMATION FROM LCM
+*----
+      CALL KDRCPU(TK1)
+      HCHAR=HNAME(:1)
+      CALL LCMGET(IPTRK,'STATE-VECTOR',ITP)
+      ISEG=ITP(17)
+      IMPV=ITP(18)
+      CALL LCMLEN(IPTRK,'MU'//HCHAR,LL4,ITYLCM)
+      CALL LCMLEN(IPTRK,'LBL'//HCHAR,LON,ITYLCM)
+      ALLOCATE(MU(LL4),LBL(LON),MUV(LL4),IPV(LL4))
+      CALL LCMGET(IPTRK,'MU'//HCHAR,MU)
+      CALL LCMGET(IPTRK,'LBL'//HCHAR,LBL)
+      CALL LCMGET(IPTRK,'MUV'//HCHAR,MUV)
+      CALL LCMGET(IPTRK,'IPV'//HCHAR,IPV)
+*
+      TEXT12=HNAME
+      IIMAX=MU(LL4)
+      LBL0=0
+      DO 10 I=1,LON
+      LBL0=LBL0+LBL(I)
+   10 CONTINUE
+      IIMAXV=MUV(LBL0)*ISEG
+      IF(ITY.EQ.1) THEN
+*        SUPERVECTORIAL TO SCALAR REBUILD.
+         ASS_PTR=LCMARA(IIMAX)
+         CALL LCMLEN(IPSYS,TEXT12,ILEN,ITYLCM)
+         IF(ILEN.NE.IIMAXV) THEN
+            WRITE(HSMG,'(38HMTBLD: REBUILD FAILURE 1 IN PROCESSING,
+     1      9H MATRIX '',A12,2H''.)') TEXT12
+            CALL XABORT(HSMG)
+         ENDIF
+         CALL LCMGPD(IPSYS,TEXT12,ASSV_PTR)
+         CALL C_F_POINTER(ASSV_PTR,ASSV,(/ IIMAXV /))
+         CALL C_F_POINTER(ASS_PTR,ASS,(/ IIMAX /))
+         CALL VECBLD(ISEG,LL4,MU,LON,LBL,MUV,IPV,1,ASS,ASSV,DUMMY(1))
+         CALL LCMPPD(IPSYS,TEXT12,IIMAX,2,ASS_PTR)
+      ELSE IF(ITY.GE.2) THEN
+*        SCALAR TO SUPERVECTORIAL REBUILD.
+         ALLOCATE(DGV(LBL0*ISEG))
+         ASSV_PTR=LCMARA(IIMAXV)
+         CALL LCMLEN(IPSYS,TEXT12,ILEN,ITYLCM)
+         IF(ILEN.NE.IIMAX) THEN
+            WRITE(HSMG,'(38HMTBLD: REBUILD FAILURE 2 IN PROCESSING,
+     1      9H MATRIX '',A12,2H''.)') TEXT12
+            CALL XABORT(HSMG)
+         ENDIF
+         CALL LCMGPD(IPSYS,TEXT12,ASS_PTR)
+         CALL C_F_POINTER(ASSV_PTR,ASSV,(/ IIMAXV /))
+         CALL C_F_POINTER(ASS_PTR,ASS,(/ IIMAX /))
+         CALL VECBLD(ISEG,LL4,MU,LON,LBL,MUV,IPV,2,ASS,ASSV,DGV(1))
+         IF(ITY.EQ.3) THEN
+            CALL LCMPUT(IPSYS,HCHAR//'D'//TEXT12(3:),LBL0*ISEG,2,DGV)
+         ENDIF
+         DEALLOCATE(DGV)
+         CALL LCMPPD(IPSYS,TEXT12,IIMAXV,2,ASSV_PTR)
+      ENDIF
+      DEALLOCATE(IPV,MUV,LBL,MU)
+      CALL KDRCPU(TK2)
+      IF(IMPV.GE.3) WRITE (6,'(/18H MTBLD: CPU TIME =,F7.2,3H S.)')
+     1 TK2-TK1
+      RETURN
+      END