1 : C XSOUR SOURCE CHAT 05/01/13 04:15:00 5004 2 : SUBROUTINE XSOUR(FN,FM,GR,PG,XYZ,HR,PGSQ,RPG, 3 : & NES,IDIM,NP,MP,NPG,IAXI,LE,IKAS,KPRE, 4 : & RGE,IKG,NELG,IPADQ,LS, 5 : & TN,IKT,TREF,IKR,IPADS, 6 : & NBEL,K0,XCOOR,F,NPT) 7 : 8 : IMPLICIT INTEGER(I-N) 9 : IMPLICIT REAL*8 (A-H,O-Z) 10 : 11 : C************************************************************************ 12 : C 13 : C OPERATEUR SOUR 14 : C - IKAS = 1 Source scalaire s : FLOTTANT ou CHPOINT SCAL CENTRE 15 : C - IKAS = 2 Source QDM s : POINT ou CHPOINT SCAL CENTRE 16 : C - IKAS = 3 Source QDM g*beta*( T - Tref ) 17 : C 18 : C************************************************************************ 19 : 20 : DIMENSION FM(MP,NPG),FN(NP,NPG),GR(IDIM,NP,NPG),PG(NPG) 21 : DIMENSION XYZ(IDIM,NP),HR(NES,NP,NPG),PGSQ(NPG),RPG(NPG) 22 : DIMENSION XCOOR(*) 23 : DIMENSION RGE(NELG,IDIM),LS(MP,*) 24 : DIMENSION LE(NP,NBEL),F(NPT,IDIM),IPADQ(*),IPADS(*) 25 : DIMENSION TN(*),TREF(*) 26 : C*********************************************************************** 27 : C write(6,*)' Debut XSOUR IKAS=',ikas 28 : C write(6,*)' MP,NELG,NP,NPT=',MP,NELG,NP,NPT 29 : C write(6,*)' IPADS ' 30 : C write(6,1001)(IPADS(ii),ii=1,100) 31 : C write(6,*)' IPADQ ' 32 : C write(6,1001)(IPADQ(ii),ii=1,100) 33 : C write(6,*)' LE ' 34 : C write(6,1001)le 35 : 36 : IF(IKAS.EQ.1)THEN 37 : C Cas source scalaire 38 : NK=K0 39 : DO 108 KE=1,NBEL 40 : NK=NK+1 41 : DO 109 I=1,NP 42 : J=LE(I,KE) 43 : DO 109 N=1,IDIM 44 : XYZ(N,I)=XCOOR((J-1)*(IDIM+1)+N) 45 : 109 CONTINUE 46 : 46 : CALL CALJBC(FN,GR,PG,XYZ,HR,PGSQ,RPG,NES, 47 : *IDIM,NP,NPG,IAXI,AIRE) 48 : 49 : DO 103 I=1,NP 50 : I1=IPADS(LE(I,KE)) 51 : U=0.D0 52 : DO 102 J=1,MP 53 : J1=IPADQ(LS(J,NK)) 54 : NKG=1+(1-IKG)*(J1-1) 55 : DO 101 L=1,NPG 56 : U=U+FN(I,L)*FM(J,L)*PGSQ(L)*RGE(NKG,N) 57 : 101 CONTINUE 58 : 102 CONTINUE 59 : F(I1,1)=F(I1,1)+U 60 : 103 CONTINUE 61 : 108 CONTINUE 62 : C write(6,*)' F ' 63 : C write(6,1002)F 64 : C write(6,*)' XSOUR FIN ' 65 : RETURN 66 : 67 : ELSEIF(IKAS.EQ.2)THEN 68 : 69 : NK=K0 70 : DO 208 KE=1,NBEL 71 : NK=NK+1 72 : DO 209 I=1,NP 73 : J=LE(I,KE) 74 : DO 209 N=1,IDIM 75 : XYZ(N,I)=XCOOR((J-1)*(IDIM+1)+N) 76 : 209 CONTINUE 77 : 77 : CALL CALJBC(FN,GR,PG,XYZ,HR,PGSQ,RPG,NES, 78 : *IDIM,NP,NPG,IAXI,AIRE) 79 : 80 : DO 204 N=1,IDIM 81 : DO 203 I=1,NP 82 : I1=IPADS(LE(I,KE)) 83 : U=0.D0 84 : DO 202 J=1,MP 85 : J1=IPADQ(LS(J,NK)) 86 : NKG=1+(1-IKG)*(J1-1) 87 : DO 201 L=1,NPG 88 : U=U+FN(I,L)*FM(J,L)*PGSQ(L)*RGE(NKG,N) 89 : 201 CONTINUE 90 : 202 CONTINUE 91 : F(I1,N)=F(I1,N)+U 92 : 203 CONTINUE 93 : 204 CONTINUE 94 : 208 CONTINUE 95 : C write(6,*)' F ' 96 : C write(6,1002)F 97 : C write(6,*)' XSOUR FIN ' 98 : RETURN 99 : 100 : ELSEIF(IKAS.EQ.3)THEN 101 : 102 : NK=K0 103 : DO 308 KE=1,NBEL 104 : NK=NK+1 105 : DO 309 I=1,NP 106 : J=LE(I,KE) 107 : DO 309 N=1,IDIM 108 : XYZ(N,I)=XCOOR((J-1)*(IDIM+1)+N) 109 : 309 CONTINUE 110 : 110 : CALL CALJBC(FN,GR,PG,XYZ,HR,PGSQ,RPG,NES, 111 : *IDIM,NP,NPG,IAXI,AIRE) 112 : 113 : NKG=1+(1-IKG)*(NK-1) 114 : 115 : DO 304 N=1,IDIM 116 : DO 303 I=1,NP 117 : I1=IPADS(LE(I,KE)) 118 : 119 : U=0.D0 120 : DO 301 L=1,NPG 121 : 122 : TT=0.D0 123 : DO 305 IB=1,NP 124 : IB1=IPADS(LE(IB,KE)) 125 : NKT=1+(1-IKT)*(IB1-1) 126 : NKR=1+(1-IKR)*(IB1-1) 127 : TT=TT+FN(IB,L)*(TN(NKT)-TREF(NKR)) 128 : 305 CONTINUE 129 : U=U+FN(I,L)*PGSQ(L)*TT 130 : 301 CONTINUE 131 : F(I1,N)=F(I1,N)-U*RGE(NKG,N) 132 : 303 CONTINUE 133 : 304 CONTINUE 134 : 308 CONTINUE 135 : C write(6,*)' F ' 136 : C write(6,1002)F 137 : C write(6,*)' XSOUR FIN ' 138 : RETURN 139 : 140 : 141 : ENDIF 142 : 143 : 144 : 145 : 1002 FORMAT(8(1X,1PE11.4)) 146 : 1001 FORMAT(20(1X,I5)) 147 : END 148 : 149 : 150 : 151 : 152 : 153 :
© Cast3M 2003 - All rights reserved.
Disclaimer