Télécharger la plaquette Cast3M


fr en

Télécharger pod.eso

Retour à la liste

Numérotation des lignes : 

pod

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

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