Télécharger k1k2.eso

Retour à la liste

Numérotation des lignes :

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

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