Télécharger la plaquette Cast3M


fr en

Télécharger hbmsor.eso

Retour à la liste

Numérotation des lignes : 

hbmsor

  1. C HBMSOR    SOURCE    FANDEUR   22/05/02    21:15:24     11359          
  2.  
  3.         SUBROUTINE HBMSOR(KSORT,KPREF,NOTYPS,NHBM) 
  4.  
  5.       IMPLICIT INTEGER(I-N)
  6.       IMPLICIT REAL*8(A-H,O-Z)
  7.  
  8.         INTEGER NOTYPS
  9.         LOGICAL ZPLUS
  10. -INC PPARAM    
  11. -INC CCOPTIO    
  12. -INC SMTABLE
  13.       POINTEUR MTAB4.MTABLE,MTAB5.MTABLE,MTAB6.MTABLE                           
  14. -INC SMLREEL  
  15. -INC SMLENTI     
  16. -INC SMLMOTS         
  17. *
  18. *
  19. ***** extrait du futur include TMDYNC.INC :
  20. *
  21. *     Segment des resultats:
  22. *     ---------------------
  23.       SEGMENT  PSORT
  24.         REAL*8 QSAVE(NT1,NPAS),WSAVE(NPAS),LSAVE(2,2*NA1,NPAS)
  25.         REAL*8 VSAVE(NPAS)
  26.         LOGICAL ZSAVE(NPAS)
  27.         CHARACTER*2 TYPBIF(NBIFU)
  28.         REAL*8 QBIFU(NT1,NBIFU),WBIFU(NBIFU),WBIF2(NBIFU)
  29.         REAL*8 QPSIR(NT1,NBIFU),QPSII(NT1,NBIFU)
  30.         INTEGER CBIF
  31.       ENDSEGMENT
  32. *     QSAVE(i,j) = Q harmonique i au pas j
  33. *     VSAVE(j)   = parametre de continuation (si non w) au j-eme pas
  34. *     ZSAVE(j)   = stabilite au j-eme pas
  35. *     LSAVE(1,j) : partie reelle de l'exposant de Floquet
  36. *     LSAVE(2,j) : partie imaginaire de l'exposant de Floquet
  37. *     TYPBIF = {LimitPoint, BranchPoint, NeimarkSacker, PeriodDoubling}
  38. *     QBIFU,WBIFU : vecteur Q et w au point de bifurcation
  39. *           WBIF2 : partie imaginaire de l'exposant de Floquet
  40. *     QPSIR,QPSII : vecteur propre au point de bifurcation
  41.  
  42. *     Segment des points de reference des modes (base A):
  43. *     --------------------------------------------------
  44.       SEGMENT MPREF
  45.          INTEGER IPOREF(NPREF)
  46.       ENDSEGMENT
  47. *      
  48. ***** fin extrait du futur include TMDYNC.INC
  49.  
  50. C Fonctions BLAS/LAPACK
  51.        REAL*8    DNRM2
  52.        EXTERNAL  DNRM2
  53.  
  54. *     recup      
  55.       PSORT=KSORT
  56.       MPREF=KPREF
  57.       NT1  = QSAVE(/1)
  58.       NPAS = QSAVE(/2)
  59.       NA1x2= LSAVE(/2)
  60.       NA1  = NA1x2 / 2
  61.  
  62. ************************************************************************
  63. *     CREATION DE LA TABLE RESULTAT 
  64. ************************************************************************
  65.       M = 3
  66.       SEGINI,MTABLE
  67.       MLOTAB = M
  68. *
  69. *     Sous-typage de la table resultat:
  70. *
  71.       CALL POSCHA('SOUSTYPE',IRET)
  72.       MTABTI(1) = 'MOT     '
  73.       MTABII(1) = IRET
  74.       MTABTV(1) = 'MOT     '
  75.       CALL POSCHA('RESULTAT_DYNC',IRET)
  76.       MTABIV(1) = IRET
  77. *
  78. *   + Sous-table REPONSE 
  79. *
  80.       CALL POSCHA('REPONSE',IRET)
  81.       MTABTI(2) = 'MOT     '
  82.       MTABII(2) = IRET
  83.       MTABTV(2) = 'TABLE   '
  84.       IF (NOTYPS.EQ.1) THEN 
  85.         M=7
  86.       ELSE 
  87.         M=6
  88.       ENDIF
  89.       SEGINI,MTAB1
  90.       MTAB1.MLOTAB = M
  91.       MTABIV(2) = MTAB1 
  92. *
  93. *   +-+ Remplissage de la Sous-table REPONSE 
  94.         CALL POSCHA('NORME_DEPLACEMENT',IRET)
  95.         MTAB1.MTABTI(1) = 'MOT     '
  96.         MTAB1.MTABII(1) = IRET
  97.         MTAB1.MTABTV(1) = 'LISTREEL'
  98.         JG=NPAS
  99.         SEGINI, MLREEL
  100.         MTAB1.MTABIV(1) = MLREEL
  101. *        
  102.         CALL POSCHA('FREQUENCE',IRET)
  103.         MTAB1.MTABTI(2) = 'MOT     '
  104.         MTAB1.MTABII(2) = IRET
  105.         MTAB1.MTABTV(2) = 'LISTREEL'
  106.         JG=NPAS
  107.         SEGINI, MLREE2
  108.         MTAB1.MTABIV(2) = MLREE2
  109. *        
  110.         CALL POSCHA('STABILITE',IRET)
  111.         MTAB1.MTABTI(3) = 'MOT     '
  112.         MTAB1.MTABII(3) = IRET
  113.         MTAB1.MTABTV(3) = 'LISTENTI'
  114.         JG=NPAS
  115.         SEGINI, MLENT3
  116.         MTAB1.MTABIV(3) = MLENT3  
  117.  
  118. *       remplissage de MLREEL = NORME_DEPLACEMENT
  119. *                      MLREE2 = FREQUENCE
  120. *                   et MLENT3 = STABILITE
  121. *
  122. c       boucle sur les pas
  123.         DO I=1,NPAS
  124. c          NORME_DEPLACEMENT
  125.            PROG(I)         = dnrm2(NT1,QSAVE(1,I),1)
  126.            IF (IERR.NE.0) RETURN
  127. c          FREQUENCE
  128.            MLREE2.PROG(I)  = WSAVE(I)
  129. c          (in)STABILITE
  130.            IF (ZSAVE(I)) THEN
  131.              MLENT3.LECT(I) = 0
  132.            ELSE
  133.              MLENT3.LECT(I) = 1
  134.            ENDIF
  135.         END DO 
  136.         SEGDES,MLREEL,MLREE2,MLENT3
  137. *        
  138. c       Remplissage de la table COEFFICIENTS
  139. *
  140.         CALL POSCHA('COEFFICIENTS',IRET)
  141.         MTAB1.MTABTI(4) = 'MOT     '
  142.         MTAB1.MTABII(4) = IRET
  143.         MTAB1.MTABTV(4) = 'TABLE   '
  144. cbp        M=NT1
  145. cbp        SEGINI,MTAB4
  146. cbp        MTAB4.MLOTAB = M
  147. cbp        MTAB1.MTABIV(4) = MTAB4
  148. cbp        DO J = 1,NT1 
  149. cbp          MTAB4.MTABTI(J) = 'ENTIER   '
  150. cbp          MTAB4.MTABII(J) = J
  151. cbp          MTAB4.MTABTV(J) = 'LISTREEL'
  152. cbp          JG = NPAS 
  153. cbp          SEGINI,MLREE2
  154. cbp          MTAB4.MTABIV(J) = MLREE2
  155. cbp          DO I = 1,NPAS
  156. cbp            MLREE2.PROG(I) = QSAVE(J,I)
  157. cbp          ENDDO
  158. cbp        ENDDO
  159. cbp        SEGDES,MTAB4,MLREE2
  160.  
  161. *       rem :  Q1 et QSAVE sont ranges dans l'ordre : 
  162. *              ( Q1^{j=0}    Q1^{j=+1}     Q1^{j=-1}  ... Q1^{j=-nhbm} )
  163. *                constant     cos(wt)       sin(wt)   ...  sin(nwt)
  164. *           J1 =   1           2             3        ...  2*nhbm+1
  165.  
  166. *       sous-table des harmoniques        
  167.         M=2*NHBM+1
  168.         SEGINI,MTAB4
  169.         MTAB4.MLOTAB = M
  170.         MTAB1.MTABIV(4) = MTAB4
  171.         JQ1=0
  172.         J  =0
  173.         ZPLUS=.true.
  174. *       boucle sur les harmoniques    
  175.         DO J1=1,2*NHBM+1
  176. *         sous-sous-table des modes
  177.           M=NA1
  178.           SEGINI,MTAB5
  179.           MTAB5.MLOTAB = M
  180.           MTAB4.MTABTI(J1) = 'ENTIER   '
  181.           MTAB4.MTABII(J1) = J
  182.           MTAB4.MTABTV(J1) = 'TABLE    '
  183.           MTAB4.MTABIV(J1) = MTAB5
  184. *         boucle sur les modes
  185.           DO IA1=1,NA1
  186.             JG = NPAS
  187.             SEGINI,MLREEL
  188. c             MTAB5.MTABTI(IA1) = 'ENTIER   '
  189. c             MTAB5.MTABII(IA1) = IA1
  190. cbp : par coherence avec DYNE, l'indice est le point_repere du mode
  191.             MTAB5.MTABTI(IA1) = 'POINT   '
  192.             MTAB5.MTABII(IA1) = IPOREF(IA1)
  193.             MTAB5.MTABTV(IA1) = 'LISTREEL'
  194.             MTAB5.MTABIV(IA1)   = MLREEL
  195.             JQ1=JQ1+1
  196.             DO I = 1,NPAS
  197.                MLREEL.PROG(I) = QSAVE(JQ1,I)
  198.             ENDDO          
  199.             SEGDES,MLREEL
  200.           ENDDO
  201. *         prochaine valeur de J
  202.           IF(ZPLUS) THEN 
  203.             J=J+J1
  204.           ELSE 
  205.             J=J-J1
  206.           ENDIF
  207.           ZPLUS=.not.ZPLUS
  208.           SEGDES,MTAB5
  209.         ENDDO          
  210.         SEGDES,MTAB4
  211. *       
  212.         CALL POSCHA('EXPOSANT_REEL',IRET)
  213.         MTAB1.MTABTI(5) = 'MOT     '
  214.         MTAB1.MTABII(5) = IRET
  215.         MTAB1.MTABTV(5) = 'TABLE   '
  216.         M=NA1x2
  217.         SEGINI,MTAB5
  218.         MTAB5.MLOTAB=M
  219.         MTAB1.MTABIV(5) = MTAB5
  220. *        
  221.         CALL POSCHA('EXPOSANT_IMAGINAIRE',IRET)
  222.         MTAB1.MTABTI(6) = 'MOT     '
  223.         MTAB1.MTABII(6) = IRET
  224.         MTAB1.MTABTV(6) = 'TABLE   '
  225.         M=NA1x2
  226.         SEGINI,MTAB6
  227.         MTAB6.MLOTAB=M
  228.         MTAB1.MTABIV(6) = MTAB6  
  229. *        
  230. c       remplissage des tables EXPOSANT_REEL et EXPOSANT_IMAGINAIRE
  231.         DO J=1,NA1x2
  232.           MTAB5.MTABTI(J) = 'ENTIER   '
  233.           MTAB5.MTABII(J) = J
  234.           MTAB5.MTABTV(J) = 'LISTREEL'
  235.           MTAB6.MTABTI(J) = 'ENTIER   '
  236.           MTAB6.MTABII(J) = J
  237.           MTAB6.MTABTV(J) = 'LISTREEL'
  238.           JG=NPAS
  239.           SEGINI,MLREE1,MLREE2
  240.           MTAB5.MTABIV(J) = MLREE1
  241.           MTAB6.MTABIV(J) = MLREE2
  242. *         remplissage des listreels µR et µI
  243.           DO I=1,NPAS
  244.             MLREE1.PROG(I)=LSAVE(1,J,I) 
  245.             MLREE2.PROG(I)=LSAVE(2,J,I) 
  246.           ENDDO
  247.         ENDDO
  248.         SEGDES,MTAB5,MTAB6,MLREE1,MLREE2
  249.  
  250. *
  251. c     cas autonome: on sauvegarde la valeur du parametre de continuation
  252.         IF (NOTYPS.EQ.1) THEN 
  253.           CALL POSCHA('PARAMC',IRET)
  254.           MTAB1.MTABTI(7) = 'MOT     '
  255.           MTAB1.MTABII(7) = IRET
  256.           MTAB1.MTABTV(7) = 'LISTREEL'
  257.           JG=NPAS
  258.           SEGINI, MLREE3
  259.           MTAB1.MTABIV(7) = MLREE3
  260.           DO I = 1,NPAS
  261.             MLREE3.PROG(I) = VSAVE(I)
  262.           ENDDO
  263.           SEGDES,MLREE3
  264.         ENDIF            
  265. *
  266. *   + Sous-table BIFURCATION
  267. *
  268.       MTABTI(3) = 'MOT     '
  269.       CALL POSCHA('BIFURCATION',IRET)
  270.       MTABII(3) = IRET
  271.       MTABTV(3) = 'TABLE   '
  272.       M=7
  273.       SEGINI,MTAB2
  274.       MTAB2.MLOTAB = M
  275.       MTABIV(3) = MTAB2   
  276. *      
  277. *   +-+ Remplissage de la Sous-table BIFURCATION 
  278.       CALL POSCHA('TYPE',IRET)
  279.       MTAB2.MTABTI(1) = 'MOT     '
  280.       MTAB2.MTABII(1) = IRET
  281.       MTAB2.MTABTV(1) = 'LISTMOTS'
  282.       JGN = 2
  283.       JGM=CBIF
  284.       SEGINI, MLMOTS
  285.       MTAB2.MTABIV(1) = MLMOTS
  286. *
  287.       CALL POSCHA('NORME_DEPLACEMENT',IRET)
  288.       MTAB2.MTABTI(2) = 'MOT     '
  289.       MTAB2.MTABII(2) = IRET
  290.       MTAB2.MTABTV(2) = 'LISTREEL'
  291.       JG=CBIF
  292.       SEGINI, MLREEL
  293.       MTAB2.MTABIV(2) = MLREEL
  294. *
  295.       CALL POSCHA('FREQUENCE',IRET)
  296.       MTAB2.MTABTI(3) = 'MOT     '
  297.       MTAB2.MTABII(3) = IRET
  298.       MTAB2.MTABTV(3) = 'LISTREEL'
  299.       JG=CBIF
  300.       SEGINI, MLREE2
  301.       MTAB2.MTABIV(3) = MLREE2
  302. *
  303.       CALL POSCHA('KAPPA',IRET)
  304.       MTAB2.MTABTI(4) = 'MOT     '
  305.       MTAB2.MTABII(4) = IRET
  306.       MTAB2.MTABTV(4) = 'LISTREEL'
  307.       JG=CBIF
  308.       SEGINI, MLREE3
  309.       MTAB2.MTABIV(4) = MLREE3
  310. *
  311. *     Remplissage de MLMOTS, MLREEL, MLREE2 et MLENT3
  312. c     Boucle sur les bifurcations
  313.       DO I=1,CBIF
  314. c     TYPE 
  315.         IF (TYPBIF(I).EQ.'L') THEN 
  316.           MOTS(I) = 'LP'        
  317.         ENDIF
  318.         IF (TYPBIF(I).EQ.'B') THEN 
  319.           MOTS(I) = 'BP'        
  320.         ENDIF
  321.         IF (TYPBIF(I).EQ.'P') THEN 
  322.           MOTS(I) = 'PD'        
  323.         ENDIF
  324.         IF (TYPBIF(I).EQ.'N') THEN 
  325.           MOTS(I) = 'NS'        
  326.         ENDIF
  327. c     NORME_DEPLACEMENT
  328.         PROG(I)         = dnrm2(NT1,QBIFU(1,I),1)
  329.         IF (IERR.NE.0) RETURN
  330. c     FREQUENCE
  331.         MLREE2.PROG(I)  = WBIFU(I)
  332. c     KAPPA
  333.         MLREE3.PROG(I)  = WBIF2(I)
  334.       ENDDO
  335.       SEGDES,MLREEL,MLREE2,MLREE3,MLMOTS
  336. *      
  337.         CALL POSCHA('VECTEUR_REEL',IRET)
  338.         MTAB2.MTABTI(5) = 'MOT     '
  339.         MTAB2.MTABII(5) = IRET
  340.         MTAB2.MTABTV(5) = 'TABLE   '
  341.         M=CBIF
  342.         SEGINI,MTAB4
  343.         MTAB4.MLOTAB=M
  344.         MTAB2.MTABIV(5) = MTAB4
  345. *        
  346.         CALL POSCHA('VECTEUR_IMAGINAIRE',IRET)
  347.         MTAB2.MTABTI(6) = 'MOT     '
  348.         MTAB2.MTABII(6) = IRET
  349.         MTAB2.MTABTV(6) = 'TABLE   '
  350.         M=CBIF
  351.         SEGINI,MTAB5
  352.         MTAB5.MLOTAB=M
  353.         MTAB2.MTABIV(6) = MTAB5  
  354. *
  355.         CALL POSCHA('COEFFICIENTS',IRET)
  356.         MTAB2.MTABTI(7) = 'MOT     '
  357.         MTAB2.MTABII(7) = IRET
  358.         MTAB2.MTABTV(7) = 'TABLE   '
  359.         M=CBIF
  360.         SEGINI,MTAB6
  361.         MTAB6.MLOTAB=M
  362.         MTAB2.MTABIV(7) = MTAB6          
  363. *        
  364. c       Remplissage des tables VECTEUR_REEL, VECTEUR_IMAGINAIRE et 
  365. c       COEFFICIENTS
  366.         DO J=1,CBIF
  367.           MTAB4.MTABTI(J) = 'ENTIER   '
  368.           MTAB4.MTABII(J) = J
  369.           MTAB4.MTABTV(J) = 'LISTREEL'
  370.           MTAB5.MTABTI(J) = 'ENTIER   '
  371.           MTAB5.MTABII(J) = J
  372.           MTAB5.MTABTV(J) = 'LISTREEL'
  373.           MTAB6.MTABTI(J) = 'ENTIER   '
  374.           MTAB6.MTABII(J) = J
  375.           MTAB6.MTABTV(J) = 'LISTREEL'
  376.           JG=NPAS
  377.           SEGINI,MLREE1,MLREE2,MLREE3
  378.           MTAB4.MTABIV(J) = MLREE1
  379.           MTAB5.MTABIV(J) = MLREE2
  380.           MTAB6.MTABIV(J) = MLREE3
  381. *         Remplissage des listreels 
  382.           DO I=1,NT1
  383.             MLREE1.PROG(I)= QPSIR(I,J)
  384.             MLREE2.PROG(I)= QPSII(I,J)
  385.             MLREE3.PROG(I)= QBIFU(I,J)            
  386.           ENDDO
  387.         ENDDO    
  388.  
  389. ************************************************************************
  390. *     FIN NORMALE : ON ECRIT LA TABLE RESULTAT
  391. ************************************************************************
  392.       CALL ECROBJ('TABLE',MTABLE)  
  393.  
  394.       END 
  395.  
  396.  
  397.  

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