38
39
40
41 USE elbufdef_mod
42 use element_mod , only : nixs
43
44
45
46#include "implicit_f.inc"
47
48
49
50#include "mvsiz_p.inc"
51#include "com04_c.inc"
52
53
54
55 INTEGER , INTENT(IN) :: JHBE,ILAY,MLWI,KCVT,IOR_TSH,
56 . NPTR,NPTS,ICSTR,NEL
57 INTEGER ,DIMENSION(NIXS,NUMELS), INTENT(IN) :: IXS
59 my_real ,
DIMENSION(3,MVSIZ),
INTENT(OUT) :: evar
60 my_real ,
DIMENSION(3,NUMNOD),
INTENT(IN) :: x
61 TYPE (ELBUF_STRUCT_), TARGET :: ELBUF_TAB
62
63
64
66 . dir(mvsiz,2),dirb(mvsiz,2)
67 INTEGER I,IR,IS,IT,JJ(4)
68
69 TYPE(G_BUFEL_) ,POINTER :: GBUF
70 TYPE(L_BUFEL_) ,POINTER :: LBUF
71
72 evar(1:3,1:nel) = zero
73 it = 1
74 ir = 0
75 is = 0
76 DO i=1,4
77 jj(i) = nel*(i-1)
78 ENDDO
79 gbuf => elbuf_tab%GBUF
80 IF (jhbe==15) THEN
81 ir = 1
82 is = 1
83 lbuf => elbuf_tab%BUFLY(ilay)%LBUF(ir,is,it)
84 IF (mlwi == 12 .OR. mlwi == 14) THEN
85 DO i=1,nel
86 evar(1:2,i) = lbuf%EPE(jj(1:2) + i)
87 evar(3,i) = half*lbuf%EPE(jj(4) + i)
88 ENDDO
89 ELSEIF (mlwi /= 49 ) THEN
90 DO i=1,nel
91 evar(1:2,i) = lbuf%STRA(jj(1:2) + i)
92 evar(3,i) = half*lbuf%STRA(jj(4) + i)
93 ENDDO
94 END IF
95
96 ELSE
97 IF (mlwi == 12 .OR. mlwi == 14) THEN
98 DO ir=1,nptr
99 DO is=1,npts
100 lbuf => elbuf_tab%BUFLY(ilay)%LBUF(ir,is,it)
101 DO i=1,nel
102 evar(1:2,i) = evar(1:2,i)+lbuf%EPE(jj(1:2) + i)
103 evar(3,i) = evar(3,i)+half*lbuf%EPE(jj(4) + i)
104 ENDDO
105 END DO
106 END DO
107 ELSEIF (mlwi /= 49 ) THEN
108 DO ir=1,nptr
109 DO is=1,npts
110 lbuf => elbuf_tab%BUFLY(ilay)%LBUF(ir,is,it)
111 DO i=1,nel
112 evar(1:2,i) = evar(1:2,i)+lbuf%STRA(jj(1:2) + i)
113 evar(3,i) = evar(3,i)+ half*lbuf%STRA(jj(4) + i)
114 ENDDO
115 ENDDO
116 END DO
117 END IF
118 END IF
119 evar(1:3,1:nel) = f_exp*evar(1:3,1:nel)
120
121 IF (kcvt==2) THEN
122 IF(ior_tsh==1)THEN
123 DO i=1,nel
124 dir(i,1:2)= gbuf%GAMA(jj(1:2) + i)
125 ENDDO
126 ELSEIF(ior_tsh==2)THEN
127 IF(jhbe==14)THEN
128 ir = 1
129 is = 1
130 END IF
131 lbuf => elbuf_tab%BUFLY(ilay)%LBUF(ir,is,it)
132 DO i=1,nel
133 dir(i,1:2)= lbuf%GAMA(jj(1:2) + i)
134 ENDDO
135 END IF
136 CALL tsh_dir2(x,ixs,dir,dirb,icstr,nel)
138 END IF
139
140 RETURN
subroutine tsh_dir2(x, ixs, dir, dirb, icstr, nel)
subroutine roto_sig2d(jft, jlt, sig, dir)