Esope source files

   1 : C MASGEN    SOURCE    CHAT      05/01/13    01:31:35     5004           
   2 :       SUBROUTINE MASGEN(IPX,PROPRE)                                             
   3 : C                                                                               
   4 : C********************************************************************           
   5 : C                                                                               
   6 : C                                                                               
   7 : C     VERSION 11/06/86    AUTEUR D. BROCHARD                                    
   8 : C     IPX  POINTEUR SUR LE MODE PROPRE (CHAMP PAR POINT)                        
   9 : C     PROPRE VOIR SIGNIFICATION DANS ITINV                                      
  10 : C                                                                               
  11 : C     SBR APPELE PAR ITINV ET SIMUL7                                            
  12 : C     CALCUL DES MASSES GENERALISEES INTRODUCTION DES COEFF.                    
  13 : C     EVENTUELS :                                                               
  14 : C       CAS PLAN AXIS. OU 3D  COEF =1.0                                               
  15 : C       CAS FOURIER (IFOPOI=1) :                                                
  16 : C         1 SEULE HARMONIQUE NHARM COEF=1.0           
  17 : C         PLUSIEURS HARMONIQUES MASSE GEN.=0  + MESSAGE D ERREUR                
  18 : C                                                                               
  19 : C     12/06/86  IFOPOI ET NOHARM NON INITIALISES (MIS =0)                       
  20 : C     PROVISOIREMENT ON UTILISERA LES VARIABLES DE OPTIO                        
  21 : C                                                                               
  22 : C     LES CARTES A RENDRE ACTIVES SERONT REPEREES PAR **                        
  23 : C                                                                               
  24 : C     08/07/86 IFOPOI ET NOHARM CORRECTS  LES ANCIENNES CARTES                  
  25 : C     SONT PRECEDEES PAR **                                                     
  26 : C                                                                               
  27 : C********************************************************************           
  28 : C                                                                               
  29 : C                                                                               
  30 :       IMPLICIT INTEGER(I-N)
  31 :       IMPLICIT REAL*8(A-H,O-Z)                                                  
  32 : -INC SMCHPOI                                                                    
  33 : -INC CCOPTIO                                                                    
  34 :       REAL*8 PROPRE(5)                                                          
  35 : C                                                                               
  36 : C                                                                               
  37 :       MCHPO1=IPX                                                                
  38 :       SEGACT MCHPO1                                                             
  39 : C                                                                               
  40 : C     CAS FOURIER                                                       
  41 : C                                                                               
  42 :       IF(MCHPO1.IFOPOI.NE.1) GOTO 2000                                            
  43 : C                                             
  44 :          NSOUPO=MCHPO1.IPCHP(/1)                                                
  45 :          DO 20 ISOUPO=1,NSOUPO                                                  
  46 :          MSOUPO=MCHPO1.IPCHP(ISOUPO)                                            
  47 :          SEGACT MSOUPO                                                          
  48 :          NC=NOHARM(/1)                                                          
  49 :          DO 30 I=1,NC                                                           
  50 :          NHARM=NOHARM(I)                                                        
  51 :          IF(ISOUPO.NE.1.OR.I.NE.1) GOTO 31                                      
  52 :          NHARM1=NHARM                                                           
  53 :          GOTO 30                                                                
  54 :    31    CONTINUE                                                               
  55 :          IF(NHARM.NE.NHARM1) GOTO 1000                                          
  56 :    30    CONTINUE                                                               
  57 :          SEGDES MSOUPO                                                          
  58 :    20    CONTINUE 
  59 :          GOTO 2000 
  60 : C                                                                               
  61 : C                                                                               
  62 : C***********************************************************                    
  63 : C        PROVISOIREMENT ON SUPPOSE QU IL N Y A QU UNE HARMONIQUE                
  64 : C        ON TESTE NIFOUR                                                        
  65 : C**10    NHARM1=NIFOUR                                                          
  66 : C                                                                               
  67 : C                                                                               
  68 : C                                                                               
  69 : C**************************************************************                 
  70 :                                                                                
  71 : C                                                                               
  72 : 1000  CONTINUE                                                                  
  73 : C                                                                               
  74 : C     PLUSIEURS HARMONIQUES                                                     
  75 : C                                                                               
  76 :       PROPRE(2)=0.D0                                                            
  77 :       IF (IIMPI.EQ.2) WRITE(IOIMP,1001)                                         
  78 : 1001  FORMAT(20X,' IL Y A PLUSIEURS HARMONIQUES DIFFERENTES ',                  
  79 :      C 'ON MET LA MASSE GENERALISEE A 0 (VERSION 11/06/86) ')                   
  80 :       GOTO 2000 
  81 : C                                                                               
  82 : C                                                                               
  83 : 2000  CONTINUE                                                                  
  84 :       SEGDES MCHPO1                                                             
  85 :       RETURN                                                                    
  86 :       END                                                                       
  87 :  
  88 :