1 : C XDUDW SOURCE FANDEUR 13/01/29 21:16:34 7683 2 : SUBROUTINE XDUDW(FN,FM,GR,PG,XYZ,HR,PGSQ,RPG,AJ, 3 : & NES,IDIM,NP,MP,NPG,IAXI,NINC, 4 : & COES,IK1,S,INDGS,IKS, 5 : & LE,NBEL,K0,XCOOR,AF,AS,CT,PQ, 6 : & AF1,AF2,AF3,AF4,AF5,AF6,AF7,AF8,AF9, 7 : & S2,NPT,IPAD,LEP,IPAP,SPQ) 8 : 9 : IMPLICIT INTEGER(I-N) 10 : IMPLICIT REAL*8 (A-H,O-Z) 11 : 12 : C************************************************************************ 13 : C 14 : C OPERATEUR DUDW 15 : C 16 : C CALCULE L'OPERATEUR DE PENALISATION DIV(U)=EPS*P 17 : C 18 : C OPTIONS : SOURCE DIV(U)-Q=EPS*P 19 : C 20 : C 21 : C************************************************************************ 22 : 23 : DIMENSION XYZ(IDIM,NP),FN(NP,NPG),GR(IDIM,NP,NPG),PG(NPG) 24 : DIMENSION FM(MP,NPG),HR(NES,NP,NPG) 25 : DIMENSION PGSQ(NPG),RPG(NPG),AJ(IDIM,IDIM,NPG) 26 : DIMENSION XCOOR(*) 27 : DIMENSION COES(1),LE(NP,NBEL),LEP(MP,*) 28 : DIMENSION AF(NP,NP,NINC,NINC),CT(MP,NP,NINC),AS(NP,NINC),PQ(MP) 29 : DIMENSION AF1(NBEL,NP,NP),AF2(NBEL,NP,NP),AF3(NBEL,NP,NP) 30 : DIMENSION AF4(NBEL,NP,NP),AF5(NBEL,NP,NP),AF6(NBEL,NP,NP) 31 : DIMENSION AF7(NBEL,NP,NP),AF8(NBEL,NP,NP),AF9(NBEL,NP,NP) 32 : DIMENSION S(*),S2(NPT,NINC),IPAD(*),IPAP(*) ,SPQ(*) 33 : REAL*8 U,UIM(10),URIM(10) 34 : C* REAL*8 UJM(10),URJM(10) 35 : C pour pression P0,P1 et P2 36 : -INC CCREEL 37 : 38 : C*********************************************************************** 39 : 40 : DEUPI=1.D0 41 : IF(IAXI.NE.0)DEUPI=2.D0*XPI 42 : 43 : NK=K0 44 : DO 108 KE=1,NBEL 45 : NK=NK+1 46 : JC=(1-IK1)*(NK-1)+1 47 : DO 109 I=1,NP 48 : J=LE(I,KE) 49 : DO 109 N=1,IDIM 50 : XYZ(N,I)=XCOOR((J-1)*(IDIM+1)+N) 51 : 109 CONTINUE 52 : 52 : CALL CALJBR 53 : &(FN,GR,PG,XYZ,HR,PGSQ,RPG,NES,IDIM,NP,NPG,IAXI,AIRE,AJ,SGN) 54 : 55 : DO 31 K=1,NINC 56 : DO 31 I=1,NP 57 : DO 39 M=1,MP 58 : UIM(M)=0.D0 59 : URIM(M)=0.D0 60 : DO 33 L=1,NPG 61 : UIM(M)=UIM(M)+FM(M,L)*HR(K,I,L)*PGSQ(L)*DEUPI*RPG(L) 62 : 33 CONTINUE 63 : IF(IAXI.NE.0.AND.K.EQ.1)THEN 64 : DO 34 L=1,NPG 65 : 34 URIM(M)=URIM(M)+FM(M,L)*FN(I,L)*PGSQ(L)*DEUPI 66 : ENDIF 67 : CT(M,I,K)=UIM(M)+URIM(M) 68 : C*?? U=U+(UIM(M)+URIM(M))*(UJM(M)+URJM(M)) 69 : 39 CONTINUE 70 : 31 CONTINUE 71 : 72 : DO 41 M=1,MP 73 : PQ(M)=0.D0 74 : DO 41 L=1,NPG 75 : PQ(M)=PQ(M)+FM(M,L)*PGSQ(L)*DEUPI*RPG(L) 76 : 41 CONTINUE 77 : 78 : DO 316 I=1,NP 79 : DO 316 J=1,NP 80 : DO 316 K=1,NINC 81 : DO 316 N=1,NINC 82 : U=0.D0 83 : DO 315 M=1,MP 84 : C? U=U+CT(M,I,K)*CT(M,J,N)/PQ(M) 85 : U=U+CT(M,I,K)*CT(M,J,N) 86 : 315 CONTINUE 87 : AF(J,I,N,K)=U/COES(JC) 88 : 316 CONTINUE 89 : 90 : C 91 : C CAS DES SOURCES OU PUITS DE MASSE 92 : C 93 : IF(INDGS.NE.0)THEN 94 : DO 73 M=1,MP 95 : J1=IPAP(LEP(M,KE)) 96 : JS=(1-IKS)*(J1-1)+1 97 : PQ(M)=0.D0 98 : DO 71 L=1,NPG 99 : PQ(M)=PQ(M)+FM(M,L)*S(JS)*PGSQ(L)*DEUPI*RPG(L) 100 : 71 CONTINUE 101 : C? SPQ(J1)=PQ(M)/COES(JC) 102 : SPQ(J1)=PQ(M) 103 : 73 CONTINUE 104 : 105 : DO 70 K=1,NINC 106 : DO 70 I=1,NP 107 : I1=IPAD(LE(I,KE)) 108 : U=0.D0 109 : DO 72 M=1,MP 110 : U=U+CT(M,I,K)*PQ(M) 111 : 72 CONTINUE 112 : S2(I1,K)=S2(I1,K)+U/COES(JC) 113 : 70 CONTINUE 114 : ENDIF 115 : 116 : 107 CONTINUE 117 : C write(6,*)' KE=',ke,' np=',np,IDIM 118 : IF(IDIM.EQ.2)THEN 119 : DO 701 I=1,NP 120 : DO 701 J=1,NP 121 : AF1(KE,J,I)=AF(J,I,1,1) 122 : AF2(KE,J,I)=AF(J,I,2,1) 123 : AF3(KE,J,I)=AF(J,I,1,2) 124 : AF4(KE,J,I)=AF(J,I,2,2) 125 : 701 CONTINUE 126 : C write(6,*)' AF1 ' 127 : C write(6,1002)AF1 128 : C write(6,*)' AF2 ' 129 : C write(6,1002)AF2 130 : C write(6,*)' AF3 ' 131 : C write(6,1002)AF3 132 : C write(6,*)' AF4 ' 133 : C write(6,1002)AF4 134 : ELSEIF(IDIM.EQ.3)THEN 135 : DO 702 I=1,NP 136 : DO 702 J=1,NP 137 : AF1(KE,J,I)=AF(J,I,1,1) 138 : AF2(KE,J,I)=AF(J,I,2,1) 139 : AF3(KE,J,I)=AF(J,I,3,1) 140 : AF4(KE,J,I)=AF(J,I,1,2) 141 : AF5(KE,J,I)=AF(J,I,2,2) 142 : AF6(KE,J,I)=AF(J,I,3,2) 143 : AF7(KE,J,I)=AF(J,I,1,3) 144 : AF8(KE,J,I)=AF(J,I,2,3) 145 : AF9(KE,J,I)=AF(J,I,3,3) 146 : 702 CONTINUE 147 : ENDIF 148 : 108 CONTINUE 149 : 150 : C write(6,*)' XDUDW FIN ' 151 : RETURN 152 : 1002 FORMAT(8(1X,1PE11.4)) 153 : 1001 FORMAT(20(1X,I5)) 154 : END 155 : 156 :
© Cast3M 2003 - All rights reserved.
Disclaimer