Télécharger pod.eso

Retour à la liste

Numérotation des lignes :

  1. C POD SOURCE CB215821 17/07/25 21:15:13 9519
  2. SUBROUTINE POD
  3. ************************************************************************
  4. * NOM : POD
  5. * DESCRIPTION : Calcule la decomposition POD (Proper Orthogonalized
  6. * Decomposition) d'un signal spatio-temporel
  7. ************************************************************************
  8. * APPELE PAR : pilot.eso
  9. ************************************************************************
  10. * SOUS-PROGRAMMES : tuu.eso => produit tU*U
  11. * tumu.eso => produit tU*M*U
  12. * utu.eso => produit U*tU
  13. * utum.eso => produit U*tU*M
  14. ************************************************************************
  15. * SYNTAXE (GIBIANE) :
  16. *
  17. * (...) = POD |LDATA1 | (LENTI1) |'SNAPSHOTS'| (MASS1) ----+
  18. * |MOT1 (MOT2) TAB1| |'CLASSIQUE'| |
  19. * |
  20. * +----------------------------------+
  21. * |
  22. * |
  23. * +----> NBMOD ('TBAS' (MAIL1)) ;
  24. *
  25. ************************************************************************
  26. IMPLICIT INTEGER(I-N)
  27. IMPLICIT REAL*8 (A-H,O-Z)
  28. -INC CCOPTIO
  29. -INC CCASSIS
  30. -INC CCNOYAU
  31. -INC SMTABLE
  32. -INC SMLCHPO
  33. -INC SMCHPOI
  34. -INC SMELEME
  35. -INC SMLENTI
  36. -INC SMLMOTS
  37. -INC SMLREEL
  38. -INC SMRIGID
  39. -INC SMSOLUT
  40. -INC CCREEL
  41. POINTEUR LCOMP.MLMOTS
  42. *
  43. PARAMETER (NMET=2)
  44. CHARACTER*4 MMET(NMET)
  45. DATA MMET/'SNAP','CLAS'/
  46. *
  47. CHARACTER*4 CHA4
  48. CHARACTER*8 CHA8
  49. CHARACTER*32 CHA32
  50. CHARACTER*40 CHA40,CHB40
  51. LOGICAL ZLOGI
  52. *
  53. COMPLEX*16 SHIFT
  54. *
  55. * TMODE = SEGMENTS DE TRAVAIL UTILISES POUR STOCKER LES VALEURS ET
  56. * LES VECTEURS PROPRES CONTENUS DANS L'OBJET SOLUTION
  57. SEGMENT TMODE
  58. INTEGER IMOD(NBSOL)
  59. REAL*8 XMOD(NBSOL)
  60. ENDSEGMENT
  61. *
  62. * TRAV1,TRAV2 = SEGMENTS DE TRAVAIL UTILISES LORS D'APPELS A ORDO
  63. SEGMENT TRAV1
  64. INTEGER ITRA((NTRA+1)/2)
  65. ENDSEGMENT
  66. SEGMENT TRAV2
  67. INTEGER IORD(NTRA)
  68. REAL*8 XORD(NTRA)
  69. REAL*8 XTRA((NTRA+1)/2)
  70. ENDSEGMENT
  71. *
  72. * TICHPO,TXCOEF = SEGMENTS UTILISES POUR L'APPEL A L'OPERATEUR COLI
  73. SEGMENT/TICHPO/(ICHPO(NCH))
  74. SEGMENT/TXCOEF/(XCOEF(NCH)*D)
  75. *
  76. ************************************************************************
  77. *
  78. * OPERATEUR UTILISABLE SEULEMENT EN 2D OU EN 3D
  79. IF (IDIM.EQ.1) THEN
  80. INTERR(1)=1
  81. CALL ERREUR(709)
  82. RETURN
  83. ENDIF
  84. *
  85. *
  86. * +---------------------------------------------------------------+
  87. * | |
  88. * | L E C T U R E D E S A R G U M E N T S |
  89. * | |
  90. * +---------------------------------------------------------------+
  91. *
  92. *
  93. * +---------------------------------------------------------------+
  94. * | S I G N A L D ' E N T R E E |
  95. * +---------------------------------------------------------------+
  96. *
  97. IPRO=0
  98. CALL LIRRES(ILCHP1,1,IPRO,CHA32,NCH,0,ILREE1)
  99. IF (IERR.NE.0) RETURN
  100. *
  101. * FILTRAGE EVENTUEL DES COMPOSANTES DU SIGNAL FOURNI
  102. * (TUU/TUMU/UTU/UTUM IGNORERONT 'LX' DONC INUTILE DE LA FILTRER ICI)
  103. CALL LIROBJ('LISTMOTS',LCOMP,0,IRET)
  104. IF (IRET.NE.0) THEN
  105. SEGACT,LCOMP
  106. NCOMP=LCOMP.MOTS(/2)
  107. IF (NCOMP.EQ.0) THEN
  108. MOTERR(1:8)='LISTMOTS'
  109. CALL ERREUR(1027)
  110. RETURN
  111. ENDIF
  112. MLCHP1=ILCHP1
  113. SEGACT,MLCHP1
  114. N1=NCH
  115. SEGINI,MLCHPO
  116. DO ICH=1,NCH
  117. ICHP1=MLCHP1.ICHPOI(ICH)
  118. ICHP2=0
  119. DO ICO=1,NCOMP
  120. CHA4=LCOMP.MOTS(ICO)
  121. CALL EXCOPP(ICHP1,CHA4,NIFOUR,ICHP3,CHA4,NIFOUR,0)
  122. IF (IERR.NE.0) RETURN
  123. IF (ICHP2.EQ.0) THEN
  124. ICHP2=ICHP3
  125. ELSE
  126. CALL ADCHPO(ICHP2,ICHP3,ICHP2,1D0,1D0)
  127. IF (IERR.NE.0) RETURN
  128. ENDIF
  129. ENDDO
  130. ICHPOI(ICH)=ICHP2
  131. ENDDO
  132. SEGDES,MLCHP1
  133. ILCHP1=MLCHPO
  134. ENDIF
  135. *
  136. *
  137. * +---------------------------------------------------------------+
  138. * | M E T H O D E D E C A L C U L |
  139. * +---------------------------------------------------------------+
  140. *
  141. * MOT-CLE "SNAPSHOTS" OU "CLASSIQUE"
  142. * (LES 4 PREMIERS CARACTERES SUFFISENT)
  143. CALL LIRCHA(CHA4,0,IRET)
  144. IF (IRET.EQ.0) GOTO 992
  145. CALL CHRMOT(MMET,NMET,CHA4,IMET)
  146. IF (IMET.EQ.0) GOTO 992
  147. *
  148. * MATRICE DE MASSE (OU DE RAIDEUR) UTILISEE LORS DE L'INTEGRATION
  149. * SUR LE MAILLAGE EN ELEMENTS FINIS
  150. CALL LIROBJ('RIGIDITE',IRIG1,0,IZRIG)
  151. * AUCUNE VERIFICATION N'EST FAITE CAR LE CAS GENERAL PEUT ETRE
  152. * TRAITE SANS PLANTAGE, MAIS THEORIQUEMENT ON ATTEND ICI PLUTOT
  153. * UNE MATRICE SYMETRIQUE DEFINIE POSITIVE
  154. *
  155. GOTO 10
  156. *
  157. 992 CONTINUE
  158. MOTERR(1:4)=CHA4
  159. WRITE(CHA8,FMT='("(",I1,"A5)")') NMET
  160. WRITE(MOTERR(5:40),FMT=CHA8) (MMET(I),I=1,NMET)
  161. CALL ERREUR(1052)
  162. RETURN
  163. *
  164. *
  165. * +---------------------------------------------------------------+
  166. * | N O M B R E D E M O D E S D E M A N D E S |
  167. * +---------------------------------------------------------------+
  168. *
  169. 10 CALL LIRENT(NBMOD,1,IRET)
  170. IF (IERR.NE.0) RETURN
  171. *
  172. IF (NBMOD.LE.0) THEN
  173. WRITE(IOIMP,*) 'Le nombre de modes doit etre strictement ',
  174. & 'positif'
  175. INTERR(1)=NBMOD
  176. CALL ERREUR(36)
  177. RETURN
  178. ELSEIF (IMET.EQ.1.AND.NBMOD.GT.NCH) THEN
  179. WRITE(IOIMP,*) "On demande plus de modes qu'il n'y a de ",
  180. & "snapshots"
  181. INTERR(1)=NBMOD
  182. CALL ERREUR(36)
  183. RETURN
  184. ENDIF
  185. *
  186. *
  187. * +---------------------------------------------------------------+
  188. * | O P T I O N " T B A S " |
  189. * +---------------------------------------------------------------+
  190. *
  191. CALL LIRCHA(CHA4,0,IZTBAS)
  192. IF (IZTBAS.EQ.0) GOTO 100
  193. *
  194. IF (CHA4.NE.'TBAS') THEN
  195. MOTERR(1:4)=CHA4
  196. MOTERR(5:40)='TBAS'
  197. CALL ERREUR(1052)
  198. RETURN
  199. ENDIF
  200. *
  201. * LECTURE EVENTUELLE D'UN MAILLAGE QUI SERA PLACE DANS LA TABLE
  202. IF (IZTBAS.NE.0) THEN
  203. CALL LIROBJ('MAILLAGE',IMAV1,0,IZMAV)
  204. ENDIF
  205. *
  206. *
  207. *
  208. *
  209. * +---------------------------------------------------------------+
  210. * | |
  211. * | M A T R I C E D E S C O R R E L A T I O N S |
  212. * | |
  213. * +---------------------------------------------------------------+
  214. *
  215. 100 CONTINUE
  216. *
  217. IF (IMET.EQ.1) THEN
  218. IF (IZRIG.EQ.0) THEN
  219. * POD "SNAPSHOTS" SANS MATRICE
  220. CALL TUU(ILCHP1,(1.D0/NCH),IRIG2)
  221. ELSE
  222. * POD "SNAPSHOTS" AVEC MATRICE
  223. CALL TUMU(ILCHP1,IRIG1,(1.D0/NCH),IRIG2)
  224. ENDIF
  225. IF (IERR.NE.0) RETURN
  226. ELSEIF (IMET.EQ.2) THEN
  227. IF (IZRIG.EQ.0) THEN
  228. * POD "CLASSIQUE" SANS MATRICE
  229. CALL UTU(ILCHP1,(1.D0/NCH),IRIG2)
  230. ELSE
  231. * POD "CLASSIQUE" AVEC MATRICE
  232. CALL UTUM(ILCHP1,IRIG1,(1.D0/NCH),IRIG2)
  233. ENDIF
  234. ENDIF
  235. *
  236. *
  237. *
  238. *
  239. * +---------------------------------------------------------------+
  240. * | |
  241. * | C A L C U L D E L A B A S E P O D |
  242. * | |
  243. * +---------------------------------------------------------------+
  244. *
  245. *
  246. * +---------------------------------------------------------------+
  247. * | E S T I M A T I O N D U S H I F T |
  248. * +---------------------------------------------------------------+
  249. * LA METHODE DE LA PUISSANCE PERMET D'OBTENIR RAPIDEMENT UNE BONNE
  250. * ESTIMATION DE LA PLUS GRANDE VALEUR PROPRE
  251. *
  252. * MCOP,MCOD = LISTMOTS CONTENANT LES COMPOSANTES PRIMALES ET DUALES
  253. CALL EXTR16(IRIG2,0,MCOP)
  254. IF (IERR.NE.0) RETURN
  255. CALL EXTR16(IRIG2,1,MCOD)
  256. IF (IERR.NE.0) RETURN
  257. *
  258. * ICHP1 = CHAMP UNITAIRE SUR LE SUPPORT DE LA MATRICE IRIG2
  259. CALL UNIFO1(IRIG2,1.,ICHP0)
  260. IF (IERR.NE.0) RETURN
  261. ICHP1=ICHP0
  262. *
  263. * XVAL1 = MAXI(ABS(ICHP1))
  264. CALL MAXIN1(ICHP1,0,' ',0,XVAL1,1,1)
  265. IF (IERR.NE.0) RETURN
  266. *
  267. * ICHP2 = ICHP1 / XVAL1
  268. C IOPERA= 5 pour l'operation DIVISION
  269. C IARGU = 2 pour CHPOINT / FLOTTANT
  270. IOPERA= 5
  271. IARGU = 2
  272. I1 = 0
  273. CALL OPCHP1(ICHP1,IOPERA,IARGU,I1,XVAL1,ICHP2,IRET)
  274. IF (IERR.NE.0) RETURN
  275. *
  276. * NITMAX=NOMBRE D'ITERATIONS MAXIMUM
  277. * RESMAX=VALEUR DU CRITERE DE CONVERGENCE
  278. NITMAX=10
  279. RESMAX=1.D-5
  280. DO I=1,NITMAX
  281. *
  282. * ICHP3 = IRIG2*ICHP2
  283. CALL MUCPRI(ICHP2,IRIG2,ICHP3)
  284. IF (IERR.NE.0) RETURN
  285. *
  286. * XVAL2 = MAXI(ABS(ICHP3))
  287. CALL MAXIN1(ICHP3,0,' ',0,XVAL2,1,1)
  288. IF (IERR.NE.0) RETURN
  289. *
  290. * ICHP4 = ICHP3 / XVAL2
  291. C IOPERA= 5 pour l'operation DIVISION
  292. C IARGU = 2 pour CHPOINT / FLOTTANT
  293. IOPERA= 5
  294. IARGU = 2
  295. I1 = 0
  296. CALL OPCHP1(ICHP3,IOPERA,IARGU,I1,XVAL2,ICHP4,IRET)
  297. IF (IERR.NE.0) RETURN
  298. *
  299. XRES1=ABS((XVAL2-XVAL1)/XVAL1)
  300. IF (XRES1.LT.RESMAX) GOTO 200
  301. *
  302. * PREPARATION DE L'ITERATION SUIVANTE
  303. CALL NOMC2(ICHP4,MCOD,MCOP,ICHP2)
  304. IF (IERR.NE.0) RETURN
  305. XVAL1=XVAL2
  306. *
  307. ENDDO
  308. 200 CONTINUE
  309. *
  310. XFREQ=0.5/XPI*(XVAL1**0.5)
  311. SHIFT=CMPLX(XFREQ,0.D0)
  312. *
  313. *
  314. * +---------------------------------------------------------------+
  315. * | R E S O L U T I O N D U S Y S T E M E M A T R I C I E L |
  316. * +---------------------------------------------------------------+
  317. *
  318. * DANS CAST3M, ON NE PEUT ACUTELLEMENT PAS CALCULER UN PROBLEME
  319. * AUX VALEURS PROPRES CLASSIQUE (AX-nX=0) ; PAR CONTRE ON SAIT
  320. * RESOUDRE SA FORME DITE GENERALISEE (KX-nMX=0)
  321. *
  322. * DETERMINATION DE LA SYMETRIE DE LA MATRICE DE "RAIDEUR" K
  323. * => NORMALEMENT, ELLE DOIT ETRE SYMETRIQUE DANS TOUS LES CAS SAUF
  324. * SI IMET=2 ET IZRIG=VRAI (POD "CLASSIQUE" AVEC MATRICE)
  325. MRIGID=IRIG2
  326. SEGACT,MRIGID
  327. ISYM2=IRIGEL(7,1)
  328. NRIGEL=IRIGEL(/2)
  329. DO I=2,NRIGEL
  330. IF (IRIGEL(7,I).NE.ISYM2) ISYM2=2
  331. ENDDO
  332. SEGDES,MRIGID
  333. *
  334. * CREATION D'UNE MATRICE "MASSE" M VALANT L'IDENTITE
  335. CALL KOPDIR(ICHP0,IMAS2)
  336. IF (IERR.NE.0) RETURN
  337. MRIGID=IMAS2
  338. SEGACT,MRIGID*MOD
  339. MTYMAT='MASSE'
  340. SEGDES,MRIGID
  341. *
  342. * RESOLUTION PROPREMENT DITE
  343. * => SUBROUTINE A CHOISIR PARMI : PROCHE, INTVAL, SIMULT, ARPACK
  344. JG=1
  345. SEGINI,MLREEL
  346. PROG(1)=XFREQ
  347. SEGDES,MLREEL
  348. SEGINI,MLENTI
  349. LECT(1)=NBMOD
  350. SEGDES,MLENTI
  351. CALL ARPACK(IRIG2,IMAS2,0,ISOLUT,SHIFT,NBMOD,'LM',ISYM2,0)
  352. IF (IERR.NE.0) RETURN
  353. *
  354. * ON RECUPERE LES DONNEES CONTENUES DANS L'OBJET SOLUTION UNE BONNE
  355. * FOIS POUR TOUTES
  356. MSOLUT=ISOLUT
  357. SEGACT,MSOLUT
  358. MSOLE1=MSOLIS(4)
  359. IF (MSOLE1.EQ.0) THEN
  360. NBSOL=0
  361. SEGINI,TMODE
  362. ELSE
  363. SEGACT,MSOLE1
  364. NBSOL=MSOLE1.ISOLEN(/1)
  365. IF (ISYM2.NE.0) NBSOL=NBSOL/2
  366. SEGINI,TMODE
  367. IF (NBSOL.NE.0) THEN
  368. MSOLE2=MSOLIS(5)
  369. SEGACT,MSOLE2
  370. DO ISOL=1,NBSOL
  371. IF (ISYM2.EQ.0) THEN
  372. IMOD(ISOL)=MSOLE2.ISOLEN(ISOL)
  373. MMODE=MSOLE1.ISOLEN(ISOL)
  374. SEGACT,MMODE
  375. XMOD(ISOL)=FMMODD(1)
  376. SEGDES,MMODE
  377. ELSE
  378. * ON VERIFIE QUE LA FREQUENCE PROPRE IMAGINAIRE EST
  379. * BIEN NULLE, SINON...
  380. MMODE=MSOLE1.ISOLEN(2*ISOL)
  381. SEGACT,MMODE
  382. IF (FMMODD(1).NE.0) THEN
  383. WRITE(IOIMP,*) 'Les modes POD sont complexes'
  384. CALL ERREUR(21)
  385. RETURN
  386. ENDIF
  387. SEGDES,MMODE
  388.  
  389. ISOL1=2*ISOL-1
  390. IMOD(ISOL)=MSOLE2.ISOLEN(ISOL1)
  391. MMODE=MSOLE1.ISOLEN(ISOL1)
  392. SEGACT,MMODE
  393. XMOD(ISOL)=FMMODD(1)
  394. SEGDES,MMODE
  395. ENDIF
  396. ENDDO
  397. SEGDES,MSOLE2
  398. ENDIF
  399. SEGDES,MSOLE1
  400. ENDIF
  401. SEGDES,MSOLUT
  402. *
  403. *
  404. * +---------------------------------------------------------------+
  405. * | C O N S T R U C T I O N D E S P O D S N A P S H O T S |
  406. * +---------------------------------------------------------------+
  407. *
  408. IF (IMET.EQ.1.AND.NBSOL.NE.0) THEN
  409. *
  410. * ON RECOPIE LES SNAPSHOTS DANS LE SEGMENT TICHPO
  411. SEGINI,TICHPO,TXCOEF
  412. MLCHPO=ILCHP1
  413. SEGACT,MLCHPO
  414. DO K=1,NCH
  415. ICHPO(K)=ICHPOI(K)
  416. ENDDO
  417. IF (IPRO.EQ.1.OR.IPRO.EQ.4) THEN
  418. SEGDES,MLCHPO
  419. ELSEIF (IPRO.EQ.2.OR.IPRO.EQ.3) THEN
  420. SEGSUP,MLCHPO
  421. ENDIF
  422. *
  423. * MAILLAGE SUPER-ELEMENT DE LA MATRICE DES CORRELATIONS
  424. MRIGID=IRIG2
  425. SEGACT,MRIGID
  426. IPT2=IRIGEL(1,1)
  427. SEGDES,MRIGID
  428. SEGACT,IPT2
  429. IF (IPT2.NUM(/1).NE.NCH) THEN
  430. CALL ERREUR(223)
  431. RETURN
  432. ENDIF
  433. *
  434. * ON RECONSTRUIT LE I-EME MODE POD EN FAISANT LA COMBINAISON
  435. * LINEAIRE DES COEFFICIENTS DU I-EME VECTEUR PROPRE AVEC LES
  436. * CHAMPS DU LISTCHPO CONTENANT LE SIGNAL (LES "SNAPSHOTS")
  437. SEGACT,MSOLE2*MOD
  438. DO ISOL=1,NBSOL
  439. MCHPO1=IMOD(ISOL)
  440. SEGACT,MCHPO1
  441. MSOUP1=MCHPO1.IPCHP(1)
  442. SEGACT,MSOUP1
  443. IPT1=MSOUP1.IGEOC
  444. MPOVA1=MSOUP1.IPOVAL
  445. SEGACT,IPT1,MPOVA1
  446. IF (IPT1.NUM(/2).NE.NCH) THEN
  447. CALL ERREUR(223)
  448. RETURN
  449. ENDIF
  450. DO 300 I=1,NCH
  451. * ON CHERCHE A QUEL CHPOINT DU LISTCHPO ON DOIT ASSOCIER
  452. * LE I-EME NOEUD DU SUPPORT DU VECTEUR PROPRE
  453. DO J=1,NCH
  454. IF (IPT1.NUM(1,I).EQ.IPT2.NUM(J,1)) THEN
  455. XCOEF(J)=MPOVA1.VPOCHA(I,1)
  456. GOTO 300
  457. ENDIF
  458. ENDDO
  459. CALL ERREUR(18)
  460. RETURN
  461. 300 CONTINUE
  462. SEGDES,MPOVA1,IPT1,MSOUP1,MCHPO1
  463. *
  464. * ON FAIT LA COMBINAISON LINEAIRE PUIS ON ENLEVE LES
  465. * MULTIPLICATEURS DE LAGRANGE
  466. CALL COMBIL(TICHPO,TXCOEF,NCH,ICHP1)
  467. IF (IERR.NE.0) RETURN
  468. MCHPOI=ICHP1
  469. SEGACT,MCHPOI*MOD
  470. NBSOU=IPCHP(/1)
  471. NAT=JATTRI(/1)
  472. NSOUPO=0
  473. DO I=1,NBSOU
  474. MSOUPO=IPCHP(I)
  475. SEGACT,MSOUPO
  476. IF (NOCOMP(1).EQ.'LX') GOTO 310
  477. NSOUPO=NSOUPO+1
  478. IPCHP(NSOUPO)=MSOUPO
  479. 310 CONTINUE
  480. SEGDES,MSOUPO
  481. ENDDO
  482. IF (NSOUPO.NE.NBSOU) SEGADJ,MCHPOI
  483. SEGDES,MCHPOI
  484. *
  485. * ON NORMALISE LES MODES (NORME INFINIE)
  486. CALL MAXIM1(ICHP1,0,' ',0,XMAX1)
  487. IF (IERR.NE.0) RETURN
  488. IF (XMAX1.NE.0.D0) THEN
  489. CALL NORMA1(ICHP1,0,' ',ICHP2)
  490. IF (IERR.NE.0) RETURN
  491. CALL DTCHPO(ICHP1)
  492. ICHP1=ICHP2
  493. ENDIF
  494. *
  495. * ON MODIFIE DIRECTEMENT LE SEGMENT TMODE (ET AUSSI L'OBJET
  496. * SOLUTION, POUR L'OPTION "TBAS") EN Y INSERANT LE MODE POD
  497. IMOD(ISOL)=ICHP1
  498. MSOLE2.ISOLEN(ISOL)=ICHP1
  499. ENDDO
  500. *
  501. SEGDES,MSOLE2
  502. SEGDES,IPT2
  503. SEGSUP,TICHPO,TXCOEF
  504. *
  505. ENDIF
  506. *
  507. *
  508. *
  509. *
  510. * +---------------------------------------------------------------+
  511. * | |
  512. * | M I S E E N F O R M E D E S R E S U L T A T S |
  513. * | |
  514. * +---------------------------------------------------------------+
  515. *
  516. *
  517. * SOUS FORME D'UN OBJET TABLE
  518. * ***************************
  519. IF (IZTBAS.NE.0) THEN
  520. *
  521. * APPEL A CRTBAS OU CCTBAS POUR TRANSFORMER L'OBJET SOLUTION
  522. * EN OBJET TABLE
  523. IF (ISYM2.EQ.0) THEN
  524. CALL CRTBAS(ISOLUT,IMAS2)
  525. IF (IERR.NE.0) RETURN
  526. ELSE
  527. CALL CCTBAS(ISOLUT,IMAS2)
  528. IF (IERR.NE.0) RETURN
  529. ENDIF
  530. CALL LIROBJ('TABLE',MTABLE,1,IRET)
  531. IF (IERR.NE.0) RETURN
  532. CHA8='TABLE'
  533. CALL ACMO(MTABLE,'MODES',CHA8,ITAB1)
  534. IF (IERR.NE.0) RETURN
  535. *
  536. * 1) SI LA MATRICE EST NON SYMETRIQUE, ON A ETE OBLIGE D'APPELER
  537. * CCTBAS ET ON DOIT MAINTENANT ENLEVER LA PARTIE IMAGINAIRE
  538. * 2) ON RAJOUTE UN INDICE "VALEUR_PROPRE" EN FIN DE TABLE
  539. CALL QUERAN(II1,'MOT',13,XVAL,'VALEUR_PROPRE',ZLOGI,IOBJ)
  540. IF (NBESC.NE.0) SEGACT,IPILOC
  541. DO ISOL=1,NBSOL
  542. * MTAB2 = SOUS-TABLE ASSOCIEE AU MODE NUMERO ISOL
  543. CALL ACCTAB(ITAB1,'ENTIER',ISOL,0.D0,'MOT',.TRUE.,0,
  544. & 'TABLE',IVAL,XVAL,CHA8,ZLOGI,MTAB2)
  545. IF (IERR.NE.0) RETURN
  546. SEGACT,MTAB2*MOD
  547. MLOTA=MTAB2.MLOTAB
  548. M=0
  549. * BOUCLE SUR LES INDICES DE MTAB2
  550. DO 410 I=1,MLOTA
  551. *
  552. * VALEUR DU I-EME INDICE (TOUJOURS DE TYPE MOT)
  553. CHA8=MTAB2.MTABTV(I)
  554. IMO1=IPCHAR(MTAB2.MTABII(I))
  555. IMO2=IPCHAR(MTAB2.MTABII(I)+1)
  556. ILON=IMO2-IMO1
  557. CHA40(1:ILON)=ICHARA(IMO1:IMO1+ILON-1)
  558. *
  559. IF (ISYM2.NE.0) THEN
  560. *
  561. * INDICE ASSOCIE A LA PARTIE IMAGINAIRE => ON SAUTE
  562. J1=INDEX(CHA40(1:ILON),'_IMAG')
  563. IF (J1.NE.0) GOTO 410
  564. *
  565. * INDICE ASSOCIE A LA PARTIE REELLE => ON RENOMME
  566. J2=INDEX(CHA40(1:ILON),'_REEL')
  567. IF (J2.NE.0) THEN
  568. IL=J2-1
  569. CHB40=CHA40(1:IL)
  570. CALL QUERAN(II2,'MOT',IL,XVAL,CHB40,ZLOGI,IOBJ)
  571. MTAB2.MTABII(I)=II2
  572. ENDIF
  573. *
  574. * DECALAGE DES DONNEES DE MTAB2 PUISQUE LES INDICES
  575. * ASSOCIES A LA PARTIE IMAGINAIRE NE SONT PLUS LA
  576. M=M+1
  577. IF (M.NE.I) THEN
  578. MTAB2.MTABTI(M)=MTAB2.MTABTI(I)
  579. MTAB2.MTABTV(M)=MTAB2.MTABTV(I)
  580. MTAB2.RMTABI(M)=MTAB2.RMTABI(I)
  581. MTAB2.MTABII(M)=MTAB2.MTABII(I)
  582. MTAB2.MTABIV(M)=MTAB2.MTABIV(I)
  583. MTAB2.RMTABV(M)=MTAB2.RMTABV(I)
  584. ENDIF
  585. *
  586. ELSE
  587. M=M+1
  588. ENDIF
  589. *
  590. * ON MEMORISE LA FREQUENCE DU MODE
  591. IF (CHA40(1:9).EQ.'FREQUENCE') XFRQ=MTAB2.RMTABV(I)
  592. *
  593. 410 CONTINUE
  594. *
  595. * ON AJOUTE UN INDICE "VALEUR_PROPRE" EN FIN DE TABLE
  596. XVAL=(2.D0*XPI*XFRQ)**2
  597. M=M+1
  598. MTAB2.MLOTAB=M
  599. SEGADJ,MTAB2
  600. MTAB2.MTABTI(M)='MOT'
  601. MTAB2.MTABTV(M)='FLOTTANT'
  602. MTAB2.MTABII(M)=II1
  603. MTAB2.RMTABV(M)=XVAL
  604. *
  605. SEGDES,MTAB2
  606. ENDDO
  607. IF (NBESC.NE.0) SEGDES,IPILOC
  608. *
  609. * ON ORDONNE LES MODES PAR VALEUR PROPRE DECROISSANTE...
  610. NTRA=NBSOL
  611. SEGINI,TRAV1,TRAV2
  612. DO ISOL=1,NBSOL
  613. CALL ACCTAB(ITAB1,'ENTIER',ISOL,0.D0,'MOT',.TRUE.,0,
  614. & 'TABLE',IVAL,XVAL,CHA8,ZLOGI,ITAB2)
  615. IF (IERR.NE.0) RETURN
  616. *
  617. * ON NE PEUT PAS UTILISER XMOD(ISOL) CAR CRTBAS/CCTBAS A
  618. * MODIFIE L'ORDRE DES MODES PAR RAPPORT A L'OBJET SOLUTION
  619. CALL ACCTAB(ITAB2,'MOT',0,0.D0,'FREQUENCE',.TRUE.,0,
  620. & 'FLOTTANT',IVAL,XVAL,CHA8,ZLOGI,IOBJ)
  621. IF (IERR.NE.0) RETURN
  622. *
  623. IMOD(ISOL)=ITAB2
  624. XORD(ISOL)=XVAL
  625. IORD(ISOL)=ISOL
  626. ENDDO
  627. CALL ORDM03(XORD(1),IORD(1),NTRA,XTRA(1),ITRA(1),.FALSE.)
  628. *
  629. * ...PUIS ON MET A JOUR LA TABLE DES MODES
  630. DO ISOL=1,NBSOL
  631. ITAB2=IMOD(IORD(ISOL))
  632. CALL ECCTAB(ITAB1,'ENTIER',ISOL,0.D0,'MOT',.TRUE.,0,
  633. & 'TABLE',IVAL,XVAL,CHA8,ZLOGI,ITAB2)
  634. CALL ECCTAB(ITAB2,'MOT',ISOL,0.D0,'NUMERO_MODE',.TRUE.,0,
  635. & 'ENTIER',ISOL,XVAL,CHA8,ZLOGI,IOBJ)
  636. ENDDO
  637. SEGSUP,TRAV1,TRAV2
  638. *
  639. * ENFIN, ON MET A JOUR LE MAILLAGE CONTENU DANS LA TABLE
  640. IF (IZMAV.EQ.0) THEN
  641. NBNN=1
  642. NBELEM=0
  643. NBSOUS=0
  644. NBREF=0
  645. SEGINI,MELEME
  646. ITYPEL=1
  647. IMAV1=MELEME
  648. SEGDES,MELEME
  649. ENDIF
  650. CALL ECCTAB(ITAB1,'MOT',ISOL,0.D0,'MAILLAGE',.TRUE.,0,
  651. & 'MAILLAGE',ISOL,XVAL,CHA8,ZLOGI,IMAV1)
  652. *
  653. *
  654. CALL ECROBJ('TABLE',MTABLE)
  655. *
  656. *
  657. * SOUS FORME DE DEUX OBJETS LISTCHPO ET LISTREEL
  658. * **********************************************
  659. ELSE
  660. *
  661. IF (NBSOL.NE.0) THEN
  662. *
  663. * ON ORDONNE LES MODES PAR VALEUR PROPRE DECROISSANTE...
  664. NTRA=NBSOL
  665. SEGINI,TRAV1,TRAV2
  666. DO ISOL=1,NBSOL
  667. XORD(ISOL)=XMOD(ISOL)
  668. IORD(ISOL)=ISOL
  669. ENDDO
  670. CALL ORDM03(XORD(1),IORD(1),NTRA,XTRA(1),ITRA(1),.FALSE.)
  671. *
  672. * ...PUIS ON REMPLIT LE LISTCHPO ET LE LISTREEL
  673. N1=NBSOL
  674. JG=NBSOL
  675. SEGINI,MLCHPO,MLREEL
  676. DO ISOL=1,NBSOL
  677. ISOL1=IORD(ISOL)
  678. PROG(ISOL)=XMOD(ISOL1)
  679. ICHPOI(ISOL)=IMOD(ISOL1)
  680. ENDDO
  681. *
  682. SEGSUP,TRAV1,TRAV2
  683. *
  684. ELSE
  685. N1=0
  686. JG=0
  687. SEGINI,MLCHPO,MLREEL
  688. ENDIF
  689. *
  690. SEGDES,MLCHPO,MLREEL
  691. *
  692. *
  693. CALL ECROBJ('LISTREEL',MLREEL)
  694. CALL ECROBJ('LISTCHPO',MLCHPO)
  695. *
  696. ENDIF
  697. *
  698. SEGSUP,TMODE
  699. *
  700. RETURN
  701. *
  702. END
  703. *
  704. *
  705.  
  706.  
  707.  
  708.  

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