Télécharger cochpo.eso

Retour à la liste

Numérotation des lignes :

  1. C COCHPO SOURCE PV 20/03/30 21:16:16 10567
  2. SUBROUTINE COCHPO(I0,I1,ITAI,ITAF)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8(A-H,O-Z)
  5. C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  6. C C CE SUBROUTINE VERIFIE QUE LES CHPOINTI0 ET I1 SONT BIEN IDENTIQUE
  7. C C EVENTUELLEMENT IL REMET LA LISTE ITAI SOUS LA FORME CORRESPONDANT
  8. C C A I0
  9. C C ECRIT PAR FARVACQUE
  10. C C APPELE PAR :FUSOLU
  11. C C APPELLE ERREUR(60)
  12. C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  13. C
  14. -INC SMELEME
  15.  
  16. -INC PPARAM
  17. -INC CCOPTIO
  18. -INC SMCHPOI
  19. -INC SMSOLUT
  20. -INC SMCOORD
  21. C
  22. CHARACTER*4 ICOMP
  23. SEGMENT ICPR(nbpts)
  24. SEGMENT ICPRR(nbpts)
  25. SEGMENT ITRAV(4,NSOUP)
  26. SEGMENT ITRACO(NC)
  27. C
  28. C ITRAV(1,I)=NPOIN (NBRE DE POINTS DANS LE IEME SOUPO)
  29. C ITRAV(2,I)=J : AU MSOUPO I CORRESPOND LE MSOUP1 J
  30. C ITRAV(3,I)=0 : AUCUN CHANGEMENT A APPLIQUER AU MSOUPO I (SINON =1)
  31. C ITRAV(4,I)=ITRACO : CONTIENT LE POINTEUR DU SEGMENT ITRACO
  32. C CCC ITRACO(J)=K : LA COMPOSANTE A LA POSITION J DANS MCHPO1 EST A LA
  33. C CCC POSITION K DANS MCHPOI
  34. C CCC MCHPOI SERA LA CONFIGURATION FINALE
  35. C
  36. MCHPOI=I0
  37. MCHPO1=I1
  38. SEGACT MCHPO1,MCHPOI
  39. NSOUP=MCHPO1.IPCHP(/1)
  40. IF(NSOUP.EQ.IPCHP(/1)) GO TO 1
  41. C LES 2 CHPOINTS DOIVENT AVOIR LE MEME NOMBRE DE SOUS CHAMPS
  42. CALL ERREUR(60)
  43. GO TO 5000
  44. 1 CONTINUE
  45. SEGINI ITRAV
  46. SEGINI ICPR
  47. SEGINI ICPRR
  48. ICPR1=nbpts
  49. DO 10 I=1,ICPR1
  50. 10 ICPR(I)=0
  51. C
  52. C *** BOUCLE SUR LES SOUPO DE MCHPOI
  53. C *** DANS ICPR(I) ON MET LE NUMERO DU SOUPO OU SE TROUVE LE POINT I
  54. C *** ICPRR(I)=K SIGNIFIE QUE I EST LE KIEME POINT DU SOUPO
  55. C
  56. DO 2 I=1,NSOUP
  57. MSOUPO=IPCHP(I)
  58. SEGACT MSOUPO
  59. MELEME=IGEOC
  60. SEGACT MELEME
  61. NPOIN=NUM(/2)
  62. ITRAV(1,I)=NPOIN
  63. DO 3 IPP=1,NPOIN
  64. J=NUM(1,IPP)
  65. ICPR(J)=I
  66. ICPRR(J)=IPP
  67. 3 CONTINUE
  68. SEGDES MELEME,MSOUPO
  69. 2 CONTINUE
  70. C
  71.  
  72. ICHPOI=MCHPOI
  73. CALL NUHARM(ICHPOI,IFO,IHAR)
  74. MCHPOI=ICHPOI
  75. C IFO=1 TOUTES LES HARMONIQUES SONT IDENTIQUES ...
  76. C ON PEUT METTRE ENSEMBLE DU MODE N ET DU MODE M
  77. C
  78. C*** BOUCLE SUR LES MSOUP1 DE MCHPO1
  79. C
  80. DO 4 I=1,NSOUP
  81. MSOUP1=MCHPO1.IPCHP(I)
  82. SEGACT MSOUP1
  83. MELEME=MSOUP1.IGEOC
  84. SEGACT MELEME
  85. NPOIN=NUM(/2)
  86. IP1=NUM(1,1)
  87. ISOUPO=ICPR(IP1)
  88. IF(ICPRR(IP1).NE.1) ITRAV(3,ISOUPO)=1
  89. IF(ISOUPO.NE.0) GO TO 5
  90. C POINT NON COMMUN AUX 2 CHPOINT
  91. CALL ERREUR(60)
  92. GO TO 5000
  93. C
  94. 5 CONTINUE
  95. IF(NPOIN.EQ.ITRAV(1,ISOUPO)) GO TO 6
  96. C LES 2 SOUPO N ONT PAS LE MEME NOMBRE DE POINTS
  97. CALL ERREUR(60)
  98. GO TO 5000
  99. C
  100. 6 CONTINUE
  101. ITRAV(2,ISOUPO)=I
  102. IF(NPOIN.EQ.1) GO TO 9
  103. DO 8 IPP=2,NPOIN
  104. IP1=NUM(1,IPP)
  105. IF(ICPRR(IP1).NE.IPP) ITRAV(3,ISOUPO)=1
  106. IF(ICPR(IP1).EQ.ISOUPO)GO TO 8
  107. C POINT NON COMMUN AUX 2 MSOUPO
  108. CALL ERREUR(60)
  109. GO TO 5000
  110. 8 CONTINUE
  111. 9 CONTINUE
  112. MSOUPO=IPCHP(ISOUPO)
  113. SEGACT MSOUPO
  114. NC=NOCOMP(/2)
  115. IF(MSOUP1.NOCOMP(/2).EQ.NC) GO TO 12
  116. CALL ERREUR(60)
  117. C PAS LE MEME NOMBRE DE COMPOSANTE
  118. GO TO 5000
  119. 12 CONTINUE
  120. SEGINI ITRACO
  121. DO 13 IC=1,NC
  122. ICOMP=MSOUP1.NOCOMP(IC)
  123. IHARM=MSOUP1.NOHARM(IC)
  124. DO 14 ICC=1,NC
  125. IF(NOCOMP(ICC).NE.ICOMP) GO TO 14
  126. IF(IFO.NE.1.AND.NOHARM(ICC).NE.IHARM) GO TO 14
  127. IF(IC.NE.ICC)ITRAV(3,ISOUPO)=1
  128. ITRACO(IC)=ICC
  129. GO TO 13
  130. 14 CONTINUE
  131. CALL ERREUR(60)
  132. C N ONT PAS LES MEMES COMPOSANTES
  133. GO TO 5000
  134. 13 CONTINUE
  135. ITRAV(4,ISOUPO)=ITRACO
  136. SEGDES ITRACO
  137. C
  138. SEGDES MSOUPO,MELEME,MSOUP1
  139. 4 CONTINUE
  140. SEGDES MCHPO1
  141. C
  142. C
  143. DO 30 I=1,NSOUP
  144. IF(ITRAV(3,I).NE.0) GO TO 41
  145. 30 CONTINUE
  146. C IL N Y A AUCUNE MODIF A FAIRE SUR LES MPOVAL
  147. C
  148. DO 31 I=1,NSOUP
  149. IF(ITRAV(2,I).EQ.I) GO TO 31
  150. GO TO 41
  151. 31 CONTINUE
  152. C IL N Y A AUCUNE MODIF A FAIRE ON SORT
  153. ITAF=ITAI
  154. GO TO 60
  155. C
  156. 41 CONTINUE
  157. C *** SI IVAL=0 IL FAUT SEULEMENT PERMUTER LES MSOUP1
  158. C *** SI IVAL=1 ON DOIT REMPLACER LES MSOUP1 PAR DES MSOUP2
  159. C
  160. MSOLE1=ITAI
  161. SEGACT MSOLE1
  162. LTAB=MSOLE1.ISOLEN(/1)
  163. N=LTAB
  164. SEGINI MSOLEN
  165. DO 42 IT=1,LTAB
  166. ISOLEN(IT)=MSOLE1.ISOLEN(IT)
  167. 42 CONTINUE
  168. SEGDES MSOLE1
  169. C
  170. DO 50 IT=1,LTAB
  171. MCHPO1=ISOLEN(IT)
  172. SEGACT MCHPO1
  173. NSOUPO=NSOUP
  174. NAT=MCHPO1.JATTRI(/1)
  175. SEGINI MCHPO2
  176. MCHPO2.IFOPOI=IFOPOI
  177. * on reprend les meme attributs
  178. DO 101 INAT=1,NAT
  179. MCHPO2.JATTRI(INAT) = MCHPO1.JATTRI(INAT)
  180. 101 CONTINUE
  181. *
  182. DO 52 IS=1,NSOUPO
  183. MSOUP1=MCHPO1.IPCHP(ITRAV(2,IS))
  184. IF(ITRAV(3,IS).NE.0) GO TO 53
  185. MCHPO2.IPCHP(IS)=MSOUP1
  186. GO TO 52
  187. 53 CONTINUE
  188. MSOUPO=IPCHP(IS)
  189. SEGACT MSOUPO,MSOUP1
  190. NC=MSOUP1.NOCOMP(/2)
  191. SEGINI MSOUP2
  192. MSOUP2.IGEOC=IGEOC
  193. DO 54 IC=1,NC
  194. MSOUP2.NOCOMP(IC)=NOCOMP(IC)
  195. MSOUP2.NOHARM(IC)=NOHARM(IC)
  196. IF(IFO.EQ.1) MSOUP2.NOHARM(IC)=MSOUP1.NOHARM(IC)
  197. 54 CONTINUE
  198. MELEME=MSOUP1.IGEOC
  199. SEGACT MELEME
  200. MPOVA1=MSOUP1.IPOVAL
  201. SEGACT MPOVA1
  202. N=MPOVA1.VPOCHA(/1)
  203. NC=MPOVA1.VPOCHA(/2)
  204. SEGINI MPOVAL
  205. ITRACO=ITRAV(4,IS)
  206. SEGACT ITRACO
  207. DO 20 IN=1,N
  208. DO 20 IC=1,NC
  209. IP1=ICPRR(NUM(1,IN))
  210. VPOCHA(IP1,ITRACO(IC))=MPOVA1.VPOCHA(IN,IC)
  211. 20 CONTINUE
  212. SEGDES ITRACO
  213. SEGDES MPOVA1,MPOVAL,MELEME
  214. MSOUP2.IPOVAL=MPOVAL
  215. SEGDES MSOUP2,MSOUP1,MSOUPO
  216. MCHPO2.IPCHP(IS)=MSOUP2
  217. 52 CONTINUE
  218. SEGDES MCHPO2,MCHPO1
  219. ISOLEN(IT)=MCHPO2
  220. 50 CONTINUE
  221. SEGDES MSOLEN
  222. ITAF=MSOLEN
  223. C
  224. 60 CONTINUE
  225. DO 58 I=1,NSOUP
  226. ITRACO=ITRAV(4,I)
  227. SEGSUP ITRACO
  228. 58 CONTINUE
  229. SEGSUP ITRAV
  230. SEGSUP ICPR,ICPRR
  231. SEGDES MCHPOI
  232. 5000 CONTINUE
  233. RETURN
  234. END
  235.  
  236.  
  237.  

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