Esope source files

   1 : C ORTVEC    SOURCE    CHAT      05/01/13    02:06:42     5004           
   2 : C     SUBROUTINE ORTVEC ( MATRED, ILDIM)
   3 : ************************************************************************        
   4 : *                                                                               
   5 : *                               ORTVEC                                       
   6 : *                             ----------                                       
   7 : *                                                                               
   8 : * FONCTION:                                                                     
   9 : * ---------                                                                     
  10 : *                                                                               
  11 : *     REALISE L'ORTHONORMALISATION D'UNE FAMILLE DE VECTEURS ECRITE
  12 : *     SOUS FOMRE DE MATRICE
  13 : *
  14 : * MODE D'APPEL:                                 
  15 : * -------------
  16 : *                                                                               
  16 : *     CALL ORTVEC ( MATRED, ILDIM)
  17 : *                                                                               
  18 : * PARAMETRES:   (E)=ENTREE   (S)=SORTIE                                         
  19 : * -----------                                                                   
  20 : *
  21 : *     MATRED  TABLEAU   (E)  TABLEAU CONTENANT LES COORDONNEES
  22 : *                            DES VECTEURS
  23 : *     MATRED  TABLEAU   (S)  TABLEAU CONTENANT LES COORDONNEES
  24 : *                            DE LA BASE
  25 : * 
  26 : *
  27 : * AUTEUR, DATE DE CREATION:                                                     
  28 : * -------------------------                                                     
  29 : *                                                                               
  30 : *   C. LE BIDEAU  09 / 2001  ( FORTRAN + ESOPE )                                       
  31 : *
  32 : ***********************************************************************
  33 :       SUBROUTINE ORTVEC ( MATRED, ILDIM)
  34 :       IMPLICIT INTEGER(I-N)
  35 :       IMPLICIT REAL*8 (A-H,O-Z) 
  36 :      
  37 : -INC  SMLREEL

  38 : 
  39 : ******
  40 : *     -- ARGUMENTS --
  41 : ***
  42 :       INTEGER  ILDIM
  43 :       SEGMENT MATRED
  44 :          REAL*8 MATVEC (N, N), MATVE1(N,N), XMAT(N, N)
  45 :       END SEGMENT
  46 :       
  47 : ******
  48 : *     PREMIER VECTEUR DE BASE
  49 : ***
  50 :          XN = 0.D0
  51 :       DO 100 IB100 = 1, ILDIM
  52 :          XN  = XN  + MATVEC(IB100, 1)**2
  53 :  100  CONTINUE
  54 :       IF (MATVEC(1,1) .GT. 0.) THEN
  55 :          DO 150 IB150 = 1, ILDIM
  56 :             MATVEC(IB150,1)= MATVEC(IB150,1)/SQRT(XN) 
  57 :  150     CONTINUE
  58 :       ELSE
  59 :          DO 160 IB160 = 1, ILDIM
  60 :             MATVEC(IB160,1)=-1.D0*MATVEC(IB160,1)/SQRT(XN)
  61 :  160     CONTINUE
  62 :       END IF
  63 :       
  64 : ******
  65 : *     AUTRES VECTEURS DE BASE IB200
  66 : ***  ** IF ILDIM SUP A 1 **
  67 :       DO 200 IB200 = 2, ILDIM 
  68 :          DO 300 IB300=1, IB200-1
  69 : ******
  70 : *     ORTHONORME AVEC IB300
  71 : ***
  72 :             XP=0.D0
  73 :             XN=0.D0
  74 : ***PRODUIT SCALAIRE
  75 :             DO 400 IB400=1, ILDIM
  76 :                XP=XP+MATVEC(IB400,IB200)*
  77 :      &         MATVEC(IB400,IB300)
  78 :  400        CONTINUE
  79 : ***ON SOUSTRAIT
  80 :             DO 500 IB500=1,ILDIM
  81 :                MATVEC(IB500,IB200)=MATVEC(IB500,IB200)
  82 :      &         -XP*MATVEC(IB500,IB300)
  83 :                XN=XN+MATVEC(IB500,IB200)**2
  84 :  500        CONTINUE
  85 :             
  86 : 
  87 : 
  88 :  300     CONTINUE
  89 : ***ON NORME SELON LE SIGNE DE LA DIAGONALE
  90 :             IF (MATVEC(IB200,IB200).GT. 0.) THEN
  91 :                DO 600 IB600=1, ILDIM
  92 :                   MATVEC(IB600,IB200)=MATVEC(IB600,IB200)
  93 :      &            /SQRT(XN)
  94 :  600        CONTINUE
  95 :             ELSE
  96 :                DO 700 IB700 = 1, ILDIM   
  97 :                   MATVEC(IB700,IB200)=-1.D0*
  98 :      &            MATVEC(IB700,IB200)/(SQRT(XN))
  99 :  700           CONTINUE
 100 :             END IF
 101 :  200  CONTINUE  
 102 :  
 103 :       END   
 104 :  
 105 :