Télécharger prosca.eso

Retour à la liste

Numérotation des lignes :

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

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