1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
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
|
