Esope source files

   1 : C HANN      SOURCE    CHAT      07/10/29    21:20:35     5940           
   2 : C HANN      SOURCE    ISPRA      90/02/22
   3 :       SUBROUTINE HANN
   4 :       IMPLICIT INTEGER(I-N)
   5 :       IMPLICIT  REAL*8(A-H,O-Z)
   6 :       CHARACTER *72 TI
   7 :       CHARACTER*12 MOTX,MOTY
   8 :       CHARACTER*2 CNH
   9 : C=======================================================================
  10 : C  =  CALCUL DE LA 'FENETRE' DE HANNING                               =
  11 : C  =                                                                  =
  12 : C  =  SYNTAXE :                                                       =
  13 : C  =                                                                  =
  14 : C  =    SPEC = HANN  EVO1 N (COUL);                                   =
  15 : C  =                                                                  =
  16 : C  =                                                                  =
  17 : C  =    EVO1    : OBJET DE TYPE EVOLUTIO CONTENANT LE SPECTRE A TRAITER=
  18 : C  =              ( UNE COURBE SEULEMENT )                            =
  19 : C  =    N       : NUMERO DE HANNING                                   =
  20 : C  =    COUL    : COULEUR ATTRIBUEE A L'OBJET CREE (FACULTATIF)       =
  21 : C  =              ( DEFAUT = COULEUR DU EVO1)                         =
  22 : C  =                                                                  =
  23 : C  =  CREATION    : 22/02/90                                          =
  24 : C  =  PROGRAMMEUR : A.P. ET P.P.                                      =
  25 : C=======================================================================
  26 : C
  27 : -INC CCGEOME
  28 : -INC CCOPTIO
  29 : -INC SMEVOLL
  30 : -INC SMLREEL
  31 : C
  32 :       SEGMENT MTRAV1
  33 :           IMPLIED XX(NPOINT),YY(NPOINT)
  34 :       ENDSEGMENT
  35 : C
  36 : C     LECTURE DE L'OBJET EVOLUTIO CONTENANT LE SPECTRE
  37 : C
  37 :       CALL LIROBJ('EVOLUTIO',IPSIG,1,IRET2)
  38 :       IF(IRET2.EQ.0) RETURN
  39 : C
  40 : C     LECTURE DU NUMERO DE HANNING
  41 : C
  41 :       CALL LIRENT(NH,1,IRET1)
  42 :       IF(IRET1.EQ.0) RETURN
  43 : C
  44 : C     LECTURE DE LA COULEUR
  45 : C
  45 :       CALL LIRMOT(NCOUL,NBCOUL,ICOUL,0)
  46 :       IF(icoul.eq.0) icoul=idcoul+1
  47 :       icoul=icoul-1
  48 : C
  49 :       IF(IERR.NE.0) RETURN
  50 : C
  51 :       MEVOL1=IPSIG
  52 :       SEGACT MEVOL1
  53 :       KEVOL1=MEVOL1.IEVOLL(1)
  54 :       SEGACT KEVOL1
  55 : C
  56 :       IF(ICOUL.EQ.0) ICOUL=KEVOL1.NUMEVX
  57 :       MOTX=KEVOL1.NOMEVX
  58 :       MOTY=KEVOL1.NOMEVY
  59 : C
  60 :       IF(NH.GT.99)THEN
  61 :         CNH='**'
  62 :       ELSE
  63 :         WRITE(CNH,'(I2)')NH
  64 :       ENDIF
  65 :       IF(NH.GT.9)THEN
  66 :         INH=1
  67 :       ELSE
  68 :         INH=2
  69 :       ENDIF
  70 :       TI='HANNING('//CNH(INH:2)//') '//MEVOL1.IEVTEX(1:59+INH)
  71 : C
  72 :       MLREE1=KEVOL1.IPROGX
  73 :       MLREE2=KEVOL1.IPROGY
  74 :       SEGACT MLREE1
  75 :       SEGACT MLREE2
  76 : C
  77 :       NPOINT=MLREE2.PROG(/1)
  78 : C
  79 :       SEGINI MTRAV1
  80 : C
  81 : C     CHARGEMENT DES TABLEAUX DE TRAVAIL
  82 : C
  83 :       DO 10 I=1,NPOINT
  84 :         XX(I)=MLREE2.PROG(I)
  85 :         YY(I)=MLREE1.PROG(I)
  86 :   10    CONTINUE
  87 : C
  88 : C     DUPLICATION DES ABSCICES
  89 : C
  90 :       SEGDES MLREE1
  91 :       JG=NPOINT
  92 :       SEGINI MLREE1
  93 :       DO 11 I=1,NPOINT
  94 :  11     MLREE1.PROG(I)=YY(I)
  95 :       SEGDES MLREE1
  96 : C
  97 : C     CALCUL DE LA FENETRE
  98 : C
  98 :       CALL HANNIN(NH,XX,NPOINT,YY)
  99 :       IF(IIMPI.EQ.1) WRITE(IOIMP,*)' CALCUL DE FENETRE '
 100 : C
 101 :       SEGDES MLREE2
 102 : C
 103 : C     CREATION ET CALCUL DES LISTES DE LA DSP
 104 : C
 105 :       JG=NPOINT
 106 :       SEGINI MLREE2
 107 :         DO 20 I=1,NPOINT
 108 :         MLREE2.PROG(I)=YY(I)
 109 :   20    CONTINUE
 110 : C
 111 :       SEGDES MLREE2
 112 : C
 113 : C     CREATION DE L'OBJET EVOLUTIO DSP
 114 : C
 115 :       N=1
 116 :       SEGINI MEVOLL
 117 :       IPVO=MEVOLL
 118 :       IEVTEX=TI
 119 :       ITYEVO='REEL'
 120 :       SEGINI KEVOLL
 121 :       KEVTEX=TI
 122 :       IEVOLL(1)=KEVOLL
 123 :       TYPX='LISTREEL'
 124 :       TYPY='LISTREEL'
 125 : C
 126 :       IPROGX=MLREE1
 127 :       NOMEVX=MOTX(1:12)
 128 : C
 129 :       IPROGY=MLREE2
 130 :       NOMEVY=MOTY(1:12)
 131 : C
 132 :       NUMEVX=ICOUL
 133 :       NUMEVY='REEL'
 134 : C
 135 :       SEGSUP MTRAV1
 136 :       SEGDES KEVOL1
 137 :       SEGDES MEVOL1
 138 : C
 139 :       SEGDES KEVOLL,MEVOLL
 139 :       CALL ECROBJ('EVOLUTIO',IPVO)
 140 : C
 141 :       RETURN
 142 :       END
 143 :  
 144 :  
 145 :  
 146 :  
 147 :  
 148 :  
 149 :  
 150 :