Télécharger prosca.eso

Retour à la liste

Numérotation des lignes :

  1. C PROSCA SOURCE CHAT 05/01/13 02:34:56 5004
  2. SUBROUTINE PROSCA(MCHPO1,MCHPO2,MLMOTX,MLMOTY,IRET)
  3. C-----------------------------------------------------------------------
  4. C PRODUIT SCALAIRE DE 2 CHPOINTS
  5. C-----------------------------------------------------------------------
  6. C EN STANDARD LE CHPOINT RESULTAT A POUR NUMERO D'HARMONIQUE 0
  7. C EN SERIE DE FOURIER , IL EST TYPE NOHARM
  8. C-----------------------------------------------------------------------
  9. C ENTREE
  10. C IPOI1 CHPOINT
  11. C IPOI2 CHPOINT
  12. C MLMOTX LISTMOTS DE COMPOSANTES ASSOCIEES AU 1-ER CHPOINT
  13. C MLMOTY LISTMOTS DE COMPOSANTES ASSOCIEES AU 2-EME CHPOINT
  14. C SORTIE
  15. C IRET POINTEUR SUR LE CHPOINT RESULTAT
  16. C-----------------------------------------------------------------------
  17. IMPLICIT INTEGER(I-N)
  18. IMPLICIT REAL*8(A-H,O-Z)
  19. -INC CCOPTIO
  20. -INC SMCHPOI
  21. -INC SMLMOTS
  22. -INC SMELEME
  23. -INC SMCOORD
  24. -INC TMTRAV
  25. CHARACTER*4 NOIN,NOMIL
  26. SEGMENT ITRAV
  27. REAL*8 IVAA(NINC,NPOI),IVAB(NINC,NPOI)
  28. INTEGER IPOS(NINC),ICPRA(NPOI),ICPRB(NPOI)
  29. CHARACTER*4 INCA(NINC),INCB(NINC)
  30. ENDSEGMENT
  31. DATA NOMIL/'NOHA'/
  32. NPOI=XCOOR(/1)/(IDIM+1)
  33. MLMOTS=MLMOTX
  34. SEGACT MLMOTS
  35. NINC= MOTS(/2)
  36. SEGINI ITRAV
  37. DO 1 I = 1, NINC
  38. INCA(I)=MOTS(I)
  39. 1 CONTINUE
  40. SEGDES MLMOTS
  41. MLMOTS=MLMOTY
  42. SEGACT MLMOTS
  43. IF(MOTS(/2).NE.NINC) THEN
  44. SEGDES MLMOTS
  45. SEGSUP ITRAV
  46. MOTERR(1:4)='PSCA'
  47. MOTERR(5:12)='LISTMOTS'
  48. CALL ERREUR(125)
  49. RETURN
  50. ENDIF
  51. DO 21 I = 1, NINC
  52. INCB(I)=MOTS(I)
  53. 21 CONTINUE
  54. SEGDES MLMOTS
  55. C
  56. C ********* IVAA CONTIENDRA LES VALEURS A MULTIPLIER PAR IVAB
  57. C ********* CREATION D'ABORD DE IVAA PUIS DE IVAB
  58. C
  59. MCHPOI=MCHPO1
  60. SEGACT MCHPOI
  61. NSOUPO = IPCHP(/1)
  62. DO 2 M = 1,NSOUPO
  63. MSOUPO = IPCHP(M)
  64. SEGACT MSOUPO
  65. NC=NOCOMP(/2)
  66. DO 10 I = 1,NINC
  67. 10 IPOS(I)=0
  68. DO 4 K = 1, NINC
  69. DO 3 J = 1, NC
  70. NOIN= NOCOMP (J)
  71. IF(INCA(K). EQ . NOIN) THEN
  72. IPOS(K)=J
  73. GO TO 4
  74. ENDIF
  75. 3 CONTINUE
  76. 4 CONTINUE
  77. DO 5 I = 1,NINC
  78. IF(IPOS(I). NE . 0) GO TO 6
  79. 5 CONTINUE
  80. GO TO 8
  81. 6 CONTINUE
  82. MELEME=IGEOC
  83. SEGACT MELEME
  84. NBELEM=NUM(/2)
  85. MPOVAL=IPOVAL
  86. SEGACT MPOVAL
  87. DO 9 LI = 1,NINC
  88. KL = IPOS(LI)
  89. IF(KL.EQ.0) GO TO 9
  90. DO 7 I = 1,NBELEM
  91. I1 = NUM(1,I)
  92. IVAA(LI,I1)=VPOCHA(I,KL)
  93. ICPRA(I1)=1
  94. 7 CONTINUE
  95. 9 CONTINUE
  96. SEGDES MELEME,MPOVAL
  97. 8 CONTINUE
  98. SEGDES MSOUPO
  99. 2 CONTINUE
  100. SEGDES MCHPOI
  101. C
  102. C TRAITEMENT DU 2-EME CHPOINT
  103. C
  104. IA=0
  105. MCHPOI=MCHPO2
  106. SEGACT MCHPOI
  107. NSOUPO = IPCHP(/1)
  108. DO 12 M = 1,NSOUPO
  109. MSOUPO = IPCHP(M)
  110. SEGACT MSOUPO
  111. NC=NOCOMP(/2)
  112. DO 11 I = 1,NINC
  113. 11 IPOS(I)=0
  114. DO 14 K= 1,NINC
  115. DO 13 J = 1, NC
  116. NOIN= NOCOMP (J)
  117. IF(INCB(K). EQ . NOIN) THEN
  118. IPOS(K)=J
  119. GO TO 14
  120. ENDIF
  121. 13 CONTINUE
  122. 14 CONTINUE
  123. DO 15 I = 1,NINC
  124. IF(IPOS(I). NE . 0) GO TO 16
  125. 15 CONTINUE
  126. GO TO 18
  127. 16 CONTINUE
  128. MELEME=IGEOC
  129. SEGACT MELEME
  130. NBELEM=NUM(/2)
  131. MPOVAL=IPOVAL
  132. SEGACT MPOVAL
  133. DO 19 LI = 1,NINC
  134. KL = IPOS(LI)
  135. IF(KL.EQ.0) GO TO 19
  136. DO 17 I = 1,NBELEM
  137. I1 = NUM(1,I)
  138. IVAB(LI,I1)=VPOCHA(I,KL)
  139. IF(ICPRA(I1).NE.0) THEN
  140. IA=IA+1
  141. ICPRB(I1)=IA
  142. ENDIF
  143. 17 CONTINUE
  144. 19 CONTINUE
  145. SEGDES MELEME,MPOVAL
  146. 18 CONTINUE
  147. SEGDES MSOUPO
  148. 12 CONTINUE
  149. IF(IA.EQ.0) THEN
  150. C
  151. C CHPOINT VIDE
  152. C
  153. SEGSUP ITRAV
  154. SEGDES MCHPOI
  155. NSOUPO=0
  156. NAT=1
  157. SEGINI MCHPOI
  158. IFOPOI=IFOUR
  159. SEGDES MCHPOI
  160. IRET=MCHPOI
  161. RETURN
  162. ENDIF
  163. C
  164. C ON EFFECTUE LE CALCUL
  165. C
  166. NNIN=1
  167. NNNOE=IA
  168. SEGINI MTRAV
  169. INCO(1)='SCAL'
  170. *
  171. * MODIF MILL LE 18 / 7 / 90
  172. * REMPLISSAGE DE L'HARMONIQUE : NOHARM SI FOURIER , 0 SINON
  173. *
  174. READ(NOMIL,FMT='(A4)') NHMIL
  175. IF(IFOPOI.EQ.1) THEN
  176. NHAR(1)=NHMIL
  177. ELSE
  178. NHAR(1)=0
  179. ENDIF
  180. *
  181. MCHPOI=MCHPO1
  182. SEGACT MCHPOI
  183. NSOUPO=IPCHP(/1)
  184. DO 22 M=1,NSOUPO
  185. MSOUPO=IPCHP(M)
  186. SEGACT MSOUPO
  187. MELEME=IGEOC
  188. SEGACT MELEME
  189. DO 27 J=1,NUM(/2)
  190. I1=NUM(1,J)
  191. IB=ICPRB(I1)
  192. IF(IB.EQ.0) GO TO 27
  193. IF(IGEO(IB).NE.0) GO TO 27
  194. IGEO(IB)=I1
  195. IBIN(1,IB)=1
  196. DO 28 LI=1,NINC
  197. 28 BB(1,IB)=BB(1,IB)+IVAA(LI,I1)*IVAB(LI,I1)
  198. 27 CONTINUE
  199. SEGDES MELEME,MSOUPO
  200. 22 CONTINUE
  201. SEGDES MCHPOI
  202. SEGSUP ITRAV
  203. CALL CRECHP(MTRAV,IRET)
  204. SEGSUP MTRAV
  205. RETURN
  206. END
  207.  
  208.  
  209.  

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