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
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
|
! { dg-do compile }
!
! PR fortran/50898
! A symbol was freed prematurely during resolution,
! despite remaining reachable
!
! Original testcase from <shaojuncycle@gmail.com>
MODULE MODULE_pmat2
IMPLICIT NONE
INTERFACE cad1b; MODULE PROCEDURE cad1b; END INTERFACE
INTERFACE csb1b; MODULE PROCEDURE csb1b; END INTERFACE
INTERFACE copbt; MODULE PROCEDURE copbt; END INTERFACE
INTERFACE conbt; MODULE PROCEDURE conbt; END INTERFACE
INTERFACE copmb; MODULE PROCEDURE copmb; END INTERFACE
INTERFACE conmb; MODULE PROCEDURE conmb; END INTERFACE
INTERFACE copbm; MODULE PROCEDURE copbm; END INTERFACE
INTERFACE conbm; MODULE PROCEDURE conbm; END INTERFACE
INTERFACE mulvb; MODULE PROCEDURE mulvb; END INTERFACE
INTERFACE madvb; MODULE PROCEDURE madvb; END INTERFACE
INTERFACE msbvb; MODULE PROCEDURE msbvb; END INTERFACE
INTERFACE mulxb; MODULE PROCEDURE mulxb; END INTERFACE
INTERFACE madxb; MODULE PROCEDURE madxb; END INTERFACE
INTERFACE msbxb; MODULE PROCEDURE msbxb; END INTERFACE
integer, parameter :: i_kind=4
integer, parameter :: r_kind=4
real(r_kind), parameter :: zero=0.0
real(r_kind), parameter :: one=1.0
real(r_kind), parameter :: two=2.0
CONTAINS
SUBROUTINE cad1b(a,m1,mah1,mah2,mirror2)
implicit none
INTEGER(i_kind), INTENT(IN ) :: m1,mah1,mah2,mirror2
REAL(r_kind), INTENT(INOUT) :: a(0:m1-1,-mah1:mah2)
RETURN
ENTRY csb1b(a,m1,mah1,mah2,mirror2)
END SUBROUTINE cad1b
SUBROUTINE copbt(a,b,m1,m2,mah1,mah2)
implicit none
INTEGER(i_kind), INTENT(IN ) :: m1, m2, mah1, mah2
REAL(r_kind), INTENT(IN ) :: a(m1,-mah1:mah2)
REAL(r_kind), INTENT( OUT) :: b(m2,-mah2:mah1)
RETURN
ENTRY conbt(a,b,m1,m2,mah1,mah2)
END SUBROUTINE copbt
SUBROUTINE copmb(afull,aband,m1,m2,mah1,mah2)
implicit none
INTEGER(i_kind), INTENT(IN ) :: m1, m2, mah1, mah2
REAL(r_kind), DIMENSION(m1,m2), INTENT(IN ) :: afull
REAL(r_kind), DIMENSION(m1,-mah1:mah2),INTENT( OUT) :: aband
RETURN
ENTRY conmb(afull,aband,m1,m2,mah1,mah2)
END SUBROUTINE copmb
SUBROUTINE copbm(aband,afull,m1,m2,mah1,mah2)
implicit none
INTEGER(i_kind), INTENT(IN ) :: m1, m2, mah1, mah2
REAL(r_kind), DIMENSION(m1,-mah1:mah2),INTENT(IN ) :: aband
REAL(r_kind), DIMENSION(m1,m2), INTENT( OUT) :: afull
RETURN
ENTRY conbm(aband,afull,m1,m2,mah1,mah2)
END SUBROUTINE copbm
SUBROUTINE mulbb(a,b,c,m1,m2,mah1,mah2,mbh1,mbh2,mch1,mch2)
implicit none
INTEGER(i_kind), INTENT(IN ) :: m1, m2, mah1, mah2, mbh1, mbh2, mch1, mch2
REAL(r_kind), INTENT(IN ) :: a(m1,-mah1:mah2), b(m2,-mbh1:mbh2)
REAL(r_kind), INTENT(INOUT) :: c(m1,-mch1:mch2)
INTEGER(i_kind) :: nch1, nch2, j, k, jpk, i1,i2
c=zero
ENTRY madbb(a,b,c,m1,m2,mah1,mah2,mbh1,mbh2,mch1,mch2)
nch1=mah1+mbh1; nch2=mah2+mbh2
IF(nch1 /= mch1 .OR. nch2 /= mch2)STOP 'In MULBB, dimensions inconsistent'
DO j=-mah1,mah2
DO k=-mbh1,mbh2; jpk=j+k; i1=MAX(1,1-j); i2=MIN(m1,m2-j)
c(i1:i2,jpk)=c(i1:i2,jpk)+a(i1:i2,j)*b(j+i1:j+i2,k)
ENDDO
ENDDO
END SUBROUTINE mulbb
SUBROUTINE MULVB(v1,a,v2, m1,m2,mah1,mah2)
implicit none
INTEGER(i_kind), INTENT(IN ) :: m1, m2, mah1, mah2
REAL(r_kind), INTENT(IN ) :: v1(m1), a(m1,-mah1:mah2)
REAL(r_kind), INTENT( OUT) :: v2(m2)
INTEGER(i_kind) :: j, i1,i2
v2=zero
ENTRY madvb(v1,a,v2, m1,m2,mah1,mah2)
DO j=-mah1,mah2; i1=MAX(1,1-j); i2=MIN(m1,m2-j)
v2(j+i1:j+i2)=v2(j+i1:j+i2)+v1(i1:i2)*a(i1:i2,j)
ENDDO
RETURN
ENTRY msbvb(v1,a,v2, m1,m2,mah1,mah2)
DO j=-mah1,mah2; i1=MAX(1,1-j); i2=MIN(m1,m2-j)
v2(j+i1:j+i2)=v2(j+i1:j+i2)-v1(i1:i2)*a(i1:i2,j)
ENDDO
END SUBROUTINE mulvb
SUBROUTINE mulxb(v1,a,v2, m1,m2,mah1,mah2,my)
implicit none
INTEGER(i_kind), INTENT(IN ) :: m1, m2, mah1, mah2, my
REAL(r_kind), INTENT(IN ) :: v1(m1,my), a(m1,-mah1:mah2)
REAL(r_kind), INTENT( OUT) :: v2(m2,my)
INTEGER(i_kind) :: i,j
v2=zero
ENTRY madxb(v1,a,v2, m1,m2,mah1,mah2,my)
DO j=-mah1,mah2
DO i=MAX(1,1-j),MIN(m1,m2-j); v2(j+i,:)=v2(j+i,:)+v1(i,:)*a(i,j); ENDDO
ENDDO
RETURN
ENTRY msbxb(v1,a,v2, m1,m2,mah1,mah2,my)
DO j=-mah1,mah2
DO i=MAX(1,1-j),MIN(m1,m2-j); v2(j+i,:)=v2(j+i,:)-v1(i,:)*a(i,j); ENDDO
ENDDO
END SUBROUTINE mulxb
SUBROUTINE mulyb(v1,a,v2, m1,m2,mah1,mah2,mx)
implicit none
INTEGER(i_kind), INTENT(IN ) :: m1, m2, mah1, mah2, mx
REAL(r_kind), INTENT(IN ) :: v1(mx,m1), a(m1,-mah1:mah2)
REAL(r_kind), INTENT( OUT) :: v2(mx,m2)
INTEGER(i_kind) :: i,j
v2=zero
ENTRY madyb(v1,a,v2, m1,m2,mah1,mah2,mx)
DO j=-mah1,mah2
DO i=MAX(1,1-j),MIN(m1,m2-j)
v2(:,j+i)=v2(:,j+i)+v1(:,i)*a(i,j)
ENDDO
ENDDO
RETURN
ENTRY msbyb(v1,a,v2, m1,m2,mah1,mah2,mx)
DO j=-mah1,mah2
DO i=MAX(1,1-j),MIN(m1,m2-j)
v2(:,j+i)=v2(:,j+i)-v1(:,i)*a(i,j)
ENDDO
ENDDO
RETURN
END SUBROUTINE mulyb
END MODULE MODULE_pmat2
|
