Télécharger muchp1.eso

Retour à la liste

Numérotation des lignes :

  1. C MUCHP1 SOURCE GOUNAND 19/12/11 21:15:09 10426
  2. SUBROUTINE MUCHP1(IPOI1,IPOI2,LMOT1,LMOT2,LMOT3,IPLREE,IEPS,IRET)
  3. C=======================================================================
  4. C
  5. C entree
  6. C ipoi1=chpoint
  7. C ipoi2=chpoint
  8. C lmot1=liste de mots1
  9. C lmot2=liste de mots2
  10. C lmot3=liste de mots3
  11. C sorties
  12. C iret = pointeur sur chpoint resultant
  13. C = 0 sinon (un message d erreur est alors imprime )
  14. C
  15. C 2018/01/19 gounand ajout du listreel de ponderation
  16. C
  17. C======================================================================
  18. IMPLICIT INTEGER(I-N)
  19. IMPLICIT REAL*8(A-H,O-Z)
  20. -INC SMCHPOI
  21. -INC CCOPTIO
  22. -INC SMELEME
  23. -INC SMLMOTS
  24. -INC SMCOORD
  25. -INC SMLREEL
  26.  
  27. C le tableau icpr contient la mise en ordre des 3 chpoint
  28. SEGMENT ICPR
  29. C nbre harm. comp points chpoints
  30. REAL*8 VALCPR(XCOOR(/1)/(IDIM+1),NCOMP1,NHAR)
  31. ENDSEGMENT
  32. C nocmp1 et le nombre de composante dans chaque listmot
  33. C nhar est le nombre d'harmonique de Fourrier présent
  34. C ce segment contient les numéro des différents harmoniques trouvées
  35. C et l'inversion du tableau
  36. SEGMENT NUMHAR(NHAR)
  37. SEGMENT IHARNU(NVHAR)
  38. C ce tableau sert de correspondance entre les composantes des liste mot
  39. C et celles des champ point pour chaque sous zone
  40. SEGMENT ICOR1(NCOMP1)
  41. SEGMENT ICOR2(NCOMP1)
  42. C
  43. C ces segment servent au moment de l'assemblage du nouveau chpoint
  44. C celui stocke le nombre de sous zone du nouveau chpoint
  45. SEGMENT JCHACO(4,NSOUP1)
  46. C indice 1 et 2 voir muchpo2 , 3 nombre de pts , 4 nbre de composante
  47. C kchaco donne l'adresse dans jchaco de la sous zone
  48. SEGMENT KCHACO(NSOUPO)
  49. SEGMENT MCORES
  50. C correspondence comp listmot comp sous zone
  51. INTEGER ICOR3(NCOMP1,NSOUPO)
  52. C indice 1 contient sum 2**i si i présent
  53. C indice 2 contient le nombre de i present
  54. INTEGER KCOMP(2,NSOUPO)
  55. INTEGER KHARM(NSOUPO)
  56. ENDSEGMENT
  57.  
  58.  
  59. LOGICAL IVCHPO
  60.  
  61.  
  62. C
  63. C ce tableau contient les pointeurs des deux champ point et des listemots
  64. DIMENSION ICHP(2),ILMO(2),NR(2)
  65. CHARACTER*4 MOTCLE(3),MONATU(1)
  66. DATA MOTCLE/'INDE','DIFF','DISC'/
  67. DATA MONATU/'NATU'/
  68. C
  69. C executable
  70. IRET=0
  71. C verification de la dimension des listmots
  72. MLMOT1=LMOT1
  73. MLMOT2=LMOT2
  74. MLMOT3=LMOT3
  75. MLREE3=0
  76. SEGACT MLMOT1,MLMOT2,MLMOT3
  77. NCOMP1 = MLMOT1.MOTS(/2)
  78. NCOMP2 = MLMOT2.MOTS(/2)
  79. NCOMP3 = MLMOT3.MOTS(/2)
  80. IF (NCOMP1.NE.NCOMP2.OR.NCOMP3.NE.NCOMP1) THEN
  81. C erreur dans la dimension des lismots
  82. CALL ERREUR(854)
  83. *new-paradigme SEGDES MLMOT1,MLMOT2,MLMOT3
  84. RETURN
  85. ENDIF
  86. if (IPLREE.gt.0) then
  87. MLREE3 = IPLREE
  88. segact mlree3
  89. if (mlree3.prog(/1).ne.ncomp1) then
  90. *new-paradigme segdes,mlmot1,mlmot2,mlmot3,mlree3
  91. MOTERR(1:8)='LIST****'
  92. MOTERR(9:16)='termes '
  93. call erreur(403)
  94. return
  95. endif
  96. endif
  97.  
  98. C determination du nombre d'harmonique de Fourrier
  99. C expédition rapide du cas sans harmonique
  100. NR(1) = 0
  101. NR(2) = 0
  102. ILMO(1)=LMOT1
  103. ILMO(2)=LMOT2
  104. ICHP(1)= IPOI1
  105. ICHP(2)= IPOI2
  106. C
  107. MCHPO1 = IPOI1
  108. MCHPO2 = IPOI2
  109. SEGACT MCHPO1,MCHPO2
  110. NHAR = 1
  111. NSUM = 0
  112. C boucle sur les 2 champoints
  113. DO 300 K=1,2
  114. MCHPO1 = ICHP(K)
  115. DO 200 I=1,MCHPO1.IPCHP(/1)
  116. MSOUPO = MCHPO1.IPCHP(I)
  117. SEGACT MSOUPO
  118. MELEME = IGEOC
  119. SEGACT MELEME
  120. NR(K) = NR(K) + NUM(/2)
  121. *new-paradigme SEGDES MELEME
  122. DO 100 J=1,NOHARM(/1)
  123. NSUM = NSUM + NOHARM(J)
  124. 100 CONTINUE
  125. 200 CONTINUE
  126. 300 CONTINUE
  127. C
  128. C combien y a t'il d'harmoniques ?
  129. C
  130. IF (NSUM .NE. 0) THEN
  131. C il y en a plusieurs
  132. C write(6,*) 'Appel de noharm'
  133. CALL NHARMO(IPOI1,IPOI2,NHAR,NUMHAR,NMIN,IHARNU)
  134. NVHAR=IHARNU(/1)
  135. ELSE
  136. C cas simple toutes les harmoniques sont nulles
  137. NHAR = 1
  138. NVHAR= 1
  139. SEGINI NUMHAR,IHARNU
  140. NUMHAR(1)=0
  141. IHARNU(1)=1
  142. NMIN=0
  143. ENDIF
  144. C
  145. C write(6,*) 'points',XCOOR(/1)/(IDIM+1),'Comp',ncomp1,'nhar',nhar
  146. C
  147. C initialisation du tableau
  148. SEGINI ICPR
  149. C ordre des opérations
  150. C cela va dépendre des remplissage respectifs NR1 et NR2
  151. C
  152. NRR1 = MAX(NR(1),NR(2))
  153. NRR2 = MIN(NR(1),NR(2))
  154. DNRR1 = REAL(NRR1)
  155. DNRR2 = REAL(NRR2)
  156. TAUX = DNRR2 / (DNRR1+0.1)
  157. C write(6,*) 'Taux de remplissage',taux
  158. C on classe les champ point dans l'ordre de taille
  159. IF ((NRR1.NE.NR(1).AND.TAUX.LT.0.5).OR.
  160. & (NRR1.EQ.NR(1).AND.TAUX.GE.0.5)) THEN
  161. C write(6,*) 'Inversion de l ordre des champoints'
  162. C write(6,*) 'Taux de remplissage' ,taux
  163. IDUM1 = ICHP(1)
  164. IDUM2 = ILMO(1)
  165. ICHP(1)=ICHP(2)
  166. ILMO(1)=ILMO(2)
  167. ICHP(2)=IDUM1
  168. ILMO(2)=IDUM2
  169. IVCHPO=.TRUE.
  170. ELSE
  171. IVCHPO=.FALSE.
  172. ENDIF
  173. C remplissage du tableau en bouclant sur les champ par points
  174. C on boucle sur les deux champ point
  175. C pour chaque sous zone on établi la correspondance de composantes du
  176. C liste mots vers les nom de composantes de la sous zone
  177. SEGINI ICOR1,ICOR2
  178. C pseudo boucle sur les champ points
  179. MCHPOI = ICHP(1)
  180.  
  181. MLMOTS = ILMO(1)
  182. DO 900 J=1,IPCHP(/1)
  183. MSOUPO = IPCHP(J)
  184. C on établi la correspondance de composantes du
  185. C liste mots vers les nom de composantes de la sous zone
  186. NC = NOHARM(/1)
  187. NC1 = 0
  188. DO 600 K=1,NCOMP1
  189. ICOR1(K)=0
  190. DO 500 L=1,NC
  191. C write(6,*) MOTS(K),NOCOMP(L)
  192. IF(MOTS(K).EQ.NOCOMP(L)) THEN
  193. C write(6,*) 'chp1 sz',j,'ccomp',l,'lcomp',k
  194. ICOR1(K)=L
  195. C nbre de composante présente sur la sous zone
  196. NC1 = NC1 + 1
  197. ICOR2(NC1)=K
  198. GOTO 600
  199. ENDIF
  200. 500 CONTINUE
  201. 600 CONTINUE
  202.  
  203. C on remplit chaque point du meleme
  204. MELEME = IGEOC
  205. MPOVAL = IPOVAL
  206. SEGACT MELEME,MPOVAL
  207. C boucle sur les composantes
  208. DO 800 K=1,NC1
  209. KK = ICOR2(K)
  210. LC = ICOR1(KK)
  211. C numero local de l'harmonique
  212. IHA = IHARNU(NOHARM(LC)-NMIN+1)
  213. C boucle sur les points
  214. DO 700 L=1,NUM(/2)
  215. NBP = NUM(1,L)
  216. C remplissage ici
  217. VALCPR(NBP,KK,IHA)
  218. & =VPOCHA(L,LC)
  219. 700 CONTINUE
  220. 800 CONTINUE
  221. *new-paradigme SEGDES MELEME,MPOVAL,MSOUPO
  222. 900 CONTINUE
  223. C
  224. C on passe au second champ point
  225. MCHPOI = ICHP(2)
  226. MLMOTS = ILMO(2)
  227. DO 1400 J=1,IPCHP(/1)
  228. MSOUPO = IPCHP(J)
  229. SEGACT MSOUPO
  230. C on établi la correspondance de composantes du
  231. C liste mots vers les nom de composantes de la sous zone
  232. NC = NOHARM(/1)
  233. NC1 = 0
  234. C
  235. ncomp1 = mots(/2)
  236. C
  237. DO 1100 K=1,NCOMP1
  238. ICOR1(K)=0
  239. DO 1000 L=1,NC
  240. C write(6,*) 'mots=',MOTS(K),'Comp=',NOCOMP(L)
  241. IF(MOTS(K).EQ.NOCOMP(L)) THEN
  242. C write(6,*) 'chp2 sz',j,'ccomp',l,'lcomp',k
  243. ICOR1(K)=L
  244. C nbre de composante présente sur la sous zone
  245. NC1 = NC1 + 1
  246. ICOR2(NC1)=K
  247. GOTO 1100
  248. ENDIF
  249. 1000 CONTINUE
  250. 1100 CONTINUE
  251.  
  252. C on remplit chaque point du meleme
  253. MELEME = IGEOC
  254. MPOVAL = IPOVAL
  255. SEGACT MELEME,MPOVAL
  256. C boucle sur les composantes
  257. DO 1300 K=1,NC1
  258. KK = ICOR2(K)
  259. LC = ICOR1(KK)
  260. C numero local de l'harmonique
  261. IHA = IHARNU(NOHARM(LC)-NMIN+1)
  262. C boucle sur les points
  263. DO 1200 L=1,NUM(/2)
  264. NBP = NUM(1,L)
  265. C multiplication ou division ici
  266. IF (IEPS.EQ.1) THEN
  267. VALCPR(NBP,KK,IHA)
  268. & =VALCPR(NBP,KK,IHA)*VPOCHA(L,LC)
  269. ELSE
  270. IF (IVCHPO) THEN
  271. VALCPR(NBP,KK,IHA)
  272. & =VPOCHA(L,LC)/VALCPR(NBP,KK,IHA)
  273. ELSE
  274. VALCPR(NBP,KK,IHA)
  275. & =VALCPR(NBP,KK,IHA)/VPOCHA(L,LC)
  276. ENDIF
  277. ENDIF
  278. 1200 CONTINUE
  279. 1300 CONTINUE
  280. *new-paradigme SEGDES MELEME,MPOVAL
  281. 1400 CONTINUE
  282. SEGSUP ICOR1,ICOR2
  283. C
  284. C
  285. C impression de icpr
  286. C WRITE(6,*) 'PTS',XCOOR(/1)/(IDIM+1),'COMP',ncomp1,'Nhar',nhar
  287. C do 6003 i=1,XCOOR(/1)/(IDIM+1)
  288. C write(6,5001) i
  289. C do 6002 j=1,ncomp1
  290. C do 6001 k=1,nhar
  291. C write(6,5002) j,k,valcpr(i,j,k)
  292. C 6001 continue
  293. C 6002 continue
  294. C 6003 continue
  295.  
  296. C 5001 format('Point numero',I4)
  297. C 5002 format('Composante',I2,'Harmonique',I2,'Valeur',G12.5)
  298.  
  299.  
  300. C
  301. C il faut maintenant creer le champ point résultat
  302. C on commence par
  303. MCHPOI=ICHP(2)
  304. MLMOTS=ILMO(2)
  305. C
  306. C muchp2 determine le nombre de sous zone de notre chpoint
  307. C
  308. C write(6,*) 'Appel à muchp2'
  309. CALL MUCHP2(MCHPOI,MLMOTS,MCORES,JCHACO,KCHACO,IHARNU,NMIN)
  310. C en sortie de mcuchp2 les segment sont actifs
  311. C
  312. C création du nouveau champ par point
  313. C
  314. C nini = jchaco(/2)
  315. C write(6,*)'tableau jchaco 1: kcomp 2:khar 3:nbre pts 4:nb comp'
  316. C do 6005 i=1,nini
  317. C write(6,5003) jchaco(1,i),jchaco(2,i),jchaco(3,i),jchaco(4,i)
  318. C 6005 continue
  319. C 5003 format(' ',4(I5,2X))
  320. C
  321. C nini = kchaco(/1)
  322. C write(6,*)'tableau kchaco correspondace 1 -> 3'
  323. C write(6,5004) (kchaco(i),i=1,nini)
  324. C 5004 format(' ',6(I2,2X))
  325. C
  326. C write(6,*) 'Tableau mcores - icor3'
  327. C nono = icor3(/1)
  328. C write(6,*) 'icor3(/1)=' ,nono
  329. C do 6004 i=1,nini
  330. C write(6,*) 'sous zone' , i
  331. C write(6,5005) (icor3(j,i),j=1,nono)
  332. C 6004 continue
  333. C 5005 format(10(I2,2X))
  334. C
  335. C attention inversion volontaire
  336. MCHPO1 = ICHP(2)
  337. MCHPO2 = ICHP(1)
  338. NSOUPO = JCHACO(/2)
  339. NAT = 1
  340. SEGINI MCHPO3
  341. NSOUP1 = NSOUPO
  342. NSOUPO= MCHPO1.IPCHP(/1)
  343. MCHPO3.MOCHDE = 'PRODUIT DE DEUX CHAMP POINT PAR *'
  344. MCHPO3.MTYPOI = ' '
  345.  
  346. C nature du champoint
  347. CALL LIRMOT(MONATU,1,IVAL,0)
  348. IF ( IVAL .EQ.1 ) THEN
  349. CALL LIRMOT(MOTCLE,3,IVAL,1)
  350. IF ( IERR .NE. 0) RETURN
  351. MCHPO3.JATTRI(1) = IVAL-1
  352. ELSE
  353. NATRI = MCHPO1.JATTRI(1) * MCHPO2.JATTRI(1)
  354. IF ( NATRI .EQ. 0) THEN
  355. MCHPO3.JATTRI(1) = 0
  356. ELSE IF ( NATRI .EQ. 1) THEN
  357. MCHPO3.JATTRI(1) = 1
  358. ELSE IF ( NATRI .EQ. 2) THEN
  359. C la nature discrete domine
  360. MCHPO3.JATTRI(1) = 2
  361. ELSE
  362. MCHPO3.JATTRI(1) = 2
  363. ENDIF
  364. ENDIF
  365. MCHPO3.IFOPOI = IFOUR
  366. C
  367. C boucle sur les sous zones DE MCHPO3
  368. C
  369. DO 2200 I=1,NSOUP1
  370. NC = JCHACO(4,I)
  371. NBELEM=JCHACO(3,I)
  372. C cas ou la sous zone n'existe pas encore
  373. SEGINI MSOUP3
  374. MCHPO3.IPCHP(I)=MSOUP3
  375. NBNN = 1
  376. C on cherche la première sous zone correspondante
  377. DO 1500 J=I,NSOUPO
  378. IF (KCHACO(J).EQ.I) GOTO 1600
  379. 1500 CONTINUE
  380. C ici j est le numéro de la premièer sous zone de mchpo1 correspondante
  381. 1600 CONTINUE
  382. MSOUP1 = MCHPO1.IPCHP(J)
  383. SEGACT MSOUP1
  384. IPT1 = MSOUP1.IGEOC
  385. SEGACT IPT1
  386. IF (NBELEM.EQ.IPT1.NUM(/2)) THEN
  387. IPT3 = IPT1
  388. ELSE
  389. NBSOUS = 0
  390. NBREF = 0
  391. NBNN = 1
  392. SEGINI IPT3
  393. DO 1650 K=1,IPT1.NUM(/2)
  394. IPT3.NUM(1,K)=IPT1.NUM(1,K)
  395. 1650 CONTINUE
  396. ENDIF
  397. MSOUP3.IGEOC = IPT3
  398. NR3 = IPT1.NUM(/2)
  399. N = NBELEM
  400. SEGINI MPOVA3
  401. MSOUP3.IPOVAL= MPOVA3
  402. C
  403. C nom des composantes et harmoniques
  404. C
  405. IC = 0
  406. DO 1800 K=1,NCOMP1
  407. IF (ICOR3(K,J).NE.0) THEN
  408. IC = IC + 1
  409. MSOUP3.NOCOMP(IC) = MLMOT3.MOTS(K)
  410. MSOUP3.NOHARM(IC) = MSOUP1.NOHARM(ICOR3(K,J))
  411. MSOUP3.NOCONS(IC) = MSOUP1.NOCONS(ICOR3(K,J))
  412. C
  413. C 1 ier remplissage
  414. C
  415. DO 1700 L=1,IPT1.NUM(/2)
  416. NBP = IPT1.NUM(1,L)
  417. XVAL=VALCPR(NBP,K,IHARNU(MSOUP3.NOHARM(IC)-NMIN+1))
  418. IF (mlree3.ne.0) xval=xval*mlree3.prog(k)
  419. MPOVA3.VPOCHA(L,IC)=XVAL
  420. 1700 CONTINUE
  421. ENDIF
  422. 1800 CONTINUE
  423. *new-paradigme SEGDES MSOUP1,IPT1
  424. C
  425. C remplissage suivant
  426. C
  427. C write(6,*) 'nr3=',nr3,'nbelem=',nbelem
  428. IF (NR3 .NE. NBELEM) THEN
  429. C write(6,*) 'Compactage de la sous zone'
  430. C on cherche la prochaine sous zone correspondante
  431. DO 2100 K=J+1,NSOUPO
  432. IF (KCHACO(K).EQ.I) THEN
  433. C k est le numéro de la sous zone de mchpo1
  434. MSOUP1 = MCHPO1.IPCHP(K)
  435. SEGACT MSOUP1
  436. IPT1 = MSOUP1.IGEOC
  437. SEGACT IPT1
  438. IC = 0
  439. DO 2000 L=1,NCOMP1
  440. IF (ICOR3(L,K).NE.0) THEN
  441. IC = IC + 1
  442. DO 1900 M=1,IPT1.NUM(/2)
  443. NBP = IPT1.NUM(1,M)
  444. IPT3.NUM(1,NR3+M) = NBP
  445. XVAL=VALCPR(NBP,L,IHARNU(MSOUP3.NOHARM(IC)
  446. $ -NMIN+1))
  447. IF (mlree3.ne.0) xval=xval*mlree3.prog(L)
  448. MPOVA3.VPOCHA(NR3+M,IC)=XVAL
  449. 1900 CONTINUE
  450. ENDIF
  451. 2000 CONTINUE
  452. NR3 = NR3 + IPT1.NUM(/2)
  453. *new-paradigme SEGDES MSOUP1,IPT1
  454. ENDIF
  455. 2100 CONTINUE
  456. IF ( NR3.NE.NBELEM.OR.NC.NE.IC)THEN
  457. C write(6,*)'nr3',nr3,'nbelem',nbelem,'nc',nc,'ic',ic
  458. WRITE(IOIMP,*) 'erreur dans muchpo1.eso'
  459. CALL ERREUR(5)
  460. RETURN
  461. ENDIF
  462. C on ferme la sous zone du nouveau chpoint
  463.  
  464. ENDIF
  465. *new-paradigme SEGDES IPT3,MPOVA3,MSOUP3
  466. 2200 CONTINUE
  467. *new-paradigme SEGDES MCHPO2,MCHPO1,MCHPO3
  468. C on détruit les temporaires
  469. SEGSUP ICPR,IHARNU,NUMHAR,JCHACO,KCHACO,MCORES
  470. *new-paradigme SEGDES ,MLMOT1,MLMOT2,MLMOT3
  471. *new-paradigme if (mlree3.ne.0) segdes mlree3
  472. IRET = MCHPO3
  473. RETURN
  474. END
  475.  
  476.  
  477.  
  478.  
  479.  
  480.  
  481.  
  482.  
  483.  

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