Esope source files

   1 : C XTY       SOURCE    KICH      06/03/17    21:17:51     5342           
   2 :       SUBROUTINE XTY                                                            
   3 :       IMPLICIT INTEGER(I-N)
   4 :       IMPLICIT REAL*8 (A-H,O-Z)                                                 
   5 : C=======================================================================        
   6 : C   OPERATEUR YTX : EFFECTUE LE PRODUIT Y * X                                   
   7 : C     ON RETIRE DU CHPOINT LES MULT. DE LAGRANGE .                              
   8 : C   SYNTAXE :  Z = XTY X Y LISMOTX LISMOTY                                      
   9 : C         Z : FLOTTANT                                                          
  10 : C         X : OBJET DE TYPE CHPOINT                                             
  11 : C         Y : OBJET DE TYPE CHPOINT                                             
  12 : C   LISMOTX : OBJET DE TYPE LISTE MOTS QUI PRECISE LES INCONNUES                
  13 : C             DE X A PRENDRE EN COMPTE                                          
  14 : C   LISMOTY : OBJET DE TYPE LISTE MOTS QUI PRECISE LES INCONNUES                
  15 : C             DE Y CORRESPONDANTES                                              
  16 : C      EX : UX UY UZ  ET FX FY FZ POUR FAIRE LE PRODUIT U * F                   
  17 : C                                                                               
  18 : C=======================================================================        
  19 : -INC CCOPTIO                                                                    
  20 : -INC SMLCHPO
  21 : -INC SMLREEL
  22 : C                                                                               
  23 : C     LECTURE D UN CHPOINT                                                      
  24 : C                                                                               
  24 :       CALL LIROBJ('CHPOINT ',MCHPOI,0,IRETOU)                                   
  25 :       IF(IERR.NE.0) GO TO 5000       
  26 :       if (iretou.ne.0) then 
  26 :         CALL LIROBJ('CHPOINT ',ICH1,1,IRETOU)                                     
  27 :         IF(IERR.NE.0) GO TO 5000                                                  
  27 :         CALL LIROBJ('LISTMOTS',MLMOTX,1,IRETOU)                                   
  28 :         IF(IERR.NE.0) GO TO 5000                                                  
  28 :         CALL LIROBJ('LISTMOTS',MLMOTY,1,IRETOU)                                   
  29 :         IF(IERR.NE.0) GO TO 5000                                                  
  29 :         CALL XTY1(MCHPOI,ICH1,MLMOTX,MLMOTY,XDRET)                                
  30 :         IF(IERR.NE.0) GO TO 5000                                                  
  30 :         CALL ECRREE(XDRET)
  31 :       endif
  32 : 
  32 :       CALL LIROBJ('LISTCHPO',LMCHPO,0,IRETOU)                                   
  33 :       IF(IERR.NE.0) GO TO 5000
  34 :       if (iretou.ne.0) then 
  34 :         CALL LIROBJ('LISTCHPOI',LICH1,1,IRETOU)                                     
  35 :         IF(IERR.NE.0) GO TO 5000                                                  
  35 :         CALL LIROBJ('LISTMOTS',MLMOTX,1,IRETOU)                                   
  36 :         IF(IERR.NE.0) GO TO 5000                                                  
  36 :         CALL LIROBJ('LISTMOTS',MLMOTY,1,IRETOU)                                   
  37 :         IF(IERR.NE.0) GO TO 5000 
  38 : 
  39 :       MLCHP1 = lmchpo 
  40 :       segact mlchp1
  41 :       n1 = mlchp1.ichpoi(/1)
  42 : 
  42 :       if (n1.le.0) call erreur(3)
  43 :       if (ierr.ne.0) return
  44 :       MLCHP2 = lich1 
  45 :       segact mlchp2
  46 : 
  47 :       jg = n1
  48 :       segini mlreel
  49 : 
  50 :       do ic = 1,n1
  51 :         mchpo1 = mlchp1.ichpoi(ic)
  52 :         mchpo2 = mlchp2.ichpoi(ic)
  52 :         CALL XTY1(MCHPO1,mchpo2,MLMOTX,MLMOTY,XDRET)                                
  53 :       if (ierr.ne.0) return
  54 : 
  55 :         prog(ic) = xdret
  56 :       enddo
  57 : 
  58 :         segdes mlchp1, mlchp2,mlreel                                                
  58 :         CALL ECROBJ('LISTREEL',mlreel)
  59 :       endif
  60 : 
  61 :  5000 CONTINUE                                                                  
  62 :       RETURN                                                                    
  63 :       END                                                                       
  64 :  
  65 :