Télécharger k1k2.eso

Retour à la liste

Numérotation des lignes :

  1. C K1K2 SOURCE MAGN 05/02/18 21:15:10 5031
  2. SUBROUTINE K1K2(MELE,MINTE,MINTE1,NBN2,NBN1,NBNN,SWORK,
  3. > KK,KERRE)
  4. C----------------------------------------------------------------------
  5. C
  6. C PASSAGE D'UN SPG DE CHAMELEM VERS UN AUTRE SPG DE DEGRE INFERIEUR ---
  7. C
  8. C----------------------------------------------------------------------
  9. IMPLICIT REAL*8(A-H,O-Z)
  10. -INC CCREEL
  11. -INC CCOPTIO
  12. -INC SMINTE
  13. SEGMENT SWORK
  14. REAL*8 VAL1(NBN1),VAL2(NBN2),VALN(NBN2)
  15. REAL*8 SHP1(6,NBN1),SHP2(6,NBN2),XE(3,NBNN)
  16. ENDSEGMENT
  17. SEGMENT/AMOI/(BM(NBN2,NBN1)*D,AM(NBN2,NBN2)*D,VAL3(NBN1)*D)
  18. C
  19. JDIM=KERRE
  20. IF(JDIM.EQ.0) THEN
  21. KERRE=29
  22. RETURN
  23. ENDIF
  24. C
  25. KERRE=0
  26.  
  27. SEGINI AMOI
  28.  
  29. C Verification cas 2D ou 3D
  30. IFR = IFOUR+4
  31. GO TO (81,81,81,81,81,82),IFR
  32. 89 KERRE=29
  33. GO TO 99
  34. 81 IDK=3
  35. GO TO 86
  36. 82 IDK=4
  37. 86 CONTINUE
  38. CCC --- CHAMP SOMMET --> CHAMP CENTRE
  39. IF(NBN2.EQ.1) THEN
  40. VV=0.D0
  41. DO 30 IC=1,MINTE1.SHPTOT(/3)
  42. DO 33 ID=1,IDK
  43. DO 331 IE=1,NBN1
  44. SHP1(ID,IE)=MINTE1.SHPTOT(ID,IE,IC)
  45. 331 CONTINUE
  46. 33 CONTINUE
  47. CALL GTEMRD(XE,SHP1,JDIM,NBN1,DJAC)
  48. DJAC=DJAC*MINTE1.POIGAU(IC)
  49. IF(IFR.EQ.4.OR.IFR.EQ.5) THEN
  50. CALL DISTRR(XE,SHP1,NBNN,RR)
  51. IF(IFR.EQ.4.OR.(IFR.EQ.5.AND.
  52. + NIFOUR.EQ.0)) THEN
  53. DJAC=DJAC*RR*2*XPI
  54. ELSE
  55. DJAC=DJAC*RR*XPI
  56. ENDIF
  57. ENDIF
  58. DO 31 IB=1,NBN1
  59. VAL3(IB)=VAL3(IB)+SHP1(1,IB)*DJAC
  60. VV=VV+SHP1(1,IB)*DJAC
  61. 31 CONTINUE
  62. 30 CONTINUE
  63. WW=0.D0
  64. DO 32 IB=1,NBN1
  65. WW=WW+VAL3(IB)*VAL1(IB)
  66. 32 CONTINUE
  67. VAL2(1)=WW/VV
  68.  
  69. CCC --- CHAMP SOMMET --> CHAMP CENTREP1 ou MSOMMET
  70. ELSE
  71. VV=0.D0
  72. DO 40 IC=1,MINTE1.SHPTOT(/3)
  73. DO 43 ID=1,IDK
  74. DO 431 IE=1,NBN1
  75. SHP1(ID,IE)=MINTE1.SHPTOT(ID,IE,IC)
  76. 431 CONTINUE
  77. DO 432 IE=1,NBN2
  78. SHP2(ID,IE)=SHPTOT(ID,IE,IC)
  79. 432 CONTINUE
  80. 43 CONTINUE
  81. IF (KK.EQ.1) THEN
  82. CALL GTEMRD(XE,SHP1,JDIM,NBNN,DJAC)
  83. DJAC=DJAC*MINTE1.POIGAU(IC)
  84. ELSEIF (KK.EQ.2) THEN
  85. CALL GTEMRD(XE,SHP2,JDIM,NBNN,DJAC)
  86. DJAC=DJAC*POIGAU(IC)
  87. ENDIF
  88. IF(IFR.EQ.4.OR.IFR.EQ.5) THEN
  89. IF (KK.EQ.1) THEN
  90. CALL DISTRR(XE,SHP1,NBNN,RR)
  91. ELSEIF (KK.EQ.2) THEN
  92. CALL DISTRR(XE,SHP2,NBNN,RR)
  93. ENDIF
  94. IF(IFR.EQ.4.OR.(IFR.EQ.5.AND.
  95. + NIFOUR.EQ.0)) THEN
  96. DJAC=DJAC*RR*2*XPI
  97. ELSE
  98. DJAC=DJAC*RR*XPI
  99. ENDIF
  100. ENDIF
  101. C
  102. C CALCUL DE LA MATRICE ET DU SECOND MEMBRE
  103. C
  104. DO 20 IA=1,NBN2
  105. DO 21 IB=1,NBN1
  106. BM(IA,IB)=BM(IA,IB)+SHP1(1,IB)*SHP2(1,IA)*DJAC
  107. 21 CONTINUE
  108. DO 22 IB=1,NBN2
  109. AM(IA,IB)=AM(IA,IB)+SHP2(1,IB)*SHP2(1,IA)*DJAC
  110. 22 CONTINUE
  111. 20 CONTINUE
  112. 40 CONTINUE
  113. C WRITE(6,77883)((BM(I,J),J=1,NBN1),I=1,NBN2)
  114. C77883 FORMAT(' MATRICE BM '/(6(1X,1PE12.5)/))
  115. C WRITE(6,77884)((AM(I,J),J=1,NBN2),I=1,NBN2)
  116. C77884 FORMAT(' MATRICE AM '/(6(1X,1PE12.5)/))
  117. SOM=0.D0
  118. DO 63 IA=1,NBN2
  119. SOM=SOM+AM(IA,IA)
  120. 63 CONTINUE
  121. IF(SOM.EQ.0.D0) THEN
  122. KERRE=358
  123. GO TO 99
  124. ENDIF
  125. PREC=SOM*1.D-40/NBN2
  126. CALL INVALM(AM,NBN2,NBN2,KERRE,PREC)
  127. C WRITE(6,77885)((AM(I,J),J=1,NBN2),I=1,NBN2)
  128. C77885 FORMAT(' MATRICE A-1'/(6(1X,1PE12.5)/))
  129. C
  130. C T{AUTRES} = (inve(A))*B*T{SOMMET}
  131. C
  132. DO 36 IA=1,NBN2
  133. SS=0.
  134. DO 37 IB=1,NBN1
  135. SS=SS+BM(IA,IB)*VAL1(IB)
  136. 37 CONTINUE
  137. VALN(IA)=SS
  138. 36 CONTINUE
  139.  
  140. DO 48 IA=1,NBN2
  141. SS=0.
  142. DO 49 IB=1,NBN2
  143. SS=SS+AM(IA,IB)*VALN(IB)
  144. 49 CONTINUE
  145. VAL2(IA)=SS
  146. 48 CONTINUE
  147. ENDIF
  148.  
  149.  
  150. 99 CONTINUE
  151. SEGSUP AMOI
  152. CC ENDIF
  153. C
  154. RETURN
  155. END
  156.  
  157.  
  158.  
  159.  
  160.  
  161.  
  162.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales