1 : C QUESHI SOURCE BP208322 13/11/13 21:15:21 7865 2 : subroutine queshi(shifti,ienc,ifin,frequ,nmodma,shipro,iexis, 3 : $icle,nn,Northo) 4 : ccc $icle,nn,fpet,fgra) 5 : * 6 : implicit real*8(a-h,o-z) 7 : implicit integer(i-n) 8 : C-INC CCREEL 9 : -INC CCOPTIO 10 : * 11 : * routine pour calculer le shift a appliquer 12 : * appelée par strate 13 : * 14 : * creation : chat 11.2009 15 : * modifs : bp 01.2010 (traitements de qq cas particuliers) 16 : * 17 : * icle=1 on cherche à partir de ifin au dessus 18 : * icle=2 on cherche au dessous 19 : * 20 : * 21 : dimension frequ(*),iexis(*) 22 : * 23 : ideca= 4 24 : imul=1 25 : ifin2=nn 26 : if (icle.eq.2) then 27 : imul = -1 28 : ifin2=1 29 : endif 30 : * 31 : *---- on commence par regarder si on est pas en presence d'un trou ----* 32 : * 33 : itrou=0 34 : do iou=ifin+imul,ifin2,imul 35 : if (iexis(iou).ne.0) then 36 : cbp itrou=(iou-ifin)*imul 37 : itrou=((iou-ifin)*imul) - 1 38 : go to 2 39 : endif 40 : enddo 41 : 2 continue 42 : c write(6,*) 'iou,ifin,ifin2,itrou,ienc=',iou,ifin,ifin2,itrou,ienc 43 : 44 : 45 : *---- on est en presence d'un trou -----------------------------------* 46 : if (itrou.ne.0) then 47 : 48 : cbp reporté + loin if (itrou.lt.ienc) then 49 : 50 : 22 continue 51 : if (icle.eq.1) then 52 : fpet=frequ(ifin) 53 : fgra=frequ(iou) 54 : else 55 : fpet=frequ(iou) 56 : fgra=frequ(ifin) 57 : endif 58 : cbp : ajout pour le cas ou delta =0 car on a raté un mode et mal numeroté 59 : c et on cherche entre 2 frequences identiques trouvées avec 2 cycles 60 : df1 = abs(fpet - fgra) / (max(1.D-6,(abs(fpet)+abs(fgra)))) 61 : if (df1.lt.1.D-4) then 62 : if (iou.ne.ifin2.and.iexis(iou+imul).ne.0) then 63 : iou=iou+imul 64 : goto 22 65 : elseif(iexis(ifin-imul).ne.0) then 66 : ifin=ifin-imul 67 : goto 22 68 : else 69 : write(6,*) 'ERREUR QUESHI : Contactez support ' 70 : stop 71 : endif 72 : endif 73 : 74 : if (itrou.lt.ienc) then 75 : fgra2=fgra*fgra 76 : fpet2=fpet*fpet 77 : c b2= 4.d0*fpet2 78 : c quatac=-2.d0*(fgra2-fpet2) 79 : c delta=b2 - quatac 80 : c if ( delta.lt.0.D0) then 80 : c call erreur(5) 81 : c return 82 : c endif 83 : c aa = sqrt(delta) 84 : c x2= (-2.d0 * fpet + aa )/ 2.d0 85 : c shipro=x2+fpet 86 : cbp : simplification 87 : fmoy2 = (fgra2 + fpet2) / 2.D0 88 : shipro = sqrt(fmoy2) 89 : cbp : cas d un petit trou, hyp. modes de multiplicite=2 => ienc*2 90 : c ienc=itrou + 1 91 : c ienc = 2 * (itrou + 1) 92 : c puisqu il y a dans strate: nmod=min ( ienc+2, nmodma), on peut reduire: 93 : ienc = 2 * itrou 94 : Northo = ienc - itrou 95 : c 96 : if (iimpi.ge.6) then 97 : WRITE(6,*) '----------------- Queshi -----------------' 98 : WRITE(IOIMP,1991) itrou,ienc,shipro 99 : 1991 FORMAT(2X,'PETIT TROU DE ',I5,' MODES' 100 : C ,'=> ON EN REDEMANDE ',I5,' AUTOUR DE ',F10.3) 101 : endif 102 : c 103 : return 104 : 105 : else 106 : * on est en presence d'un trou et itrou>ienc donc on avait visé beaucoup 107 : * trop loin 108 : fpet=frequ(ifin) 109 : friou=frequ(iou) 110 : fgra= fpet + ( friou -fpet)/itrou*ienc 111 : Northo = 0 112 : go to 3 113 : endif 114 : 115 : *---- pas de trou ----------------------------------------------------* 116 : else 117 : cbp : on ne passe ici que pour un cas improbable 118 : if ( icle.eq.2) then 119 : if (ifin-ienc.le.0) then 120 : WRITE(6,*) '!!! on ne passe ici que pour un cas improbable !!!' 121 : ienc=ifin - 1 122 : shipro=0.d0 123 : Northo = ienc 124 : return 125 : endif 126 : endif 127 : 128 : endif 129 : 130 : *---- calcul du shift a partir de la pente de y=freq(numero_mode) ----* 131 : * (cas sans trou) 132 : fpet= frequ(ifin) 133 : idec5 = ifin- (ideca*imul) 134 : idec10 = ifin- 2*(ideca*imul) 135 : idec20 = ifin- 4*(ideca*imul) 136 : pentm=0.D0 137 : pent5=0.D0 138 : pent10=0.D0 139 : pent20=0.D0 140 : cbp13/10/2010 : pentm = pente moyenne 141 : ndec = 0 142 : cbp plutot que 3,2,1 on prend 1,2,3 pour une moyenne + equilibrée 143 : icoe1 = 1 144 : icoe2 = 2 145 : icoe3 = 3 146 : if (idec5.gt.0) then 147 : if (iexis(idec5).ne.0) then 148 : pent5 = fpet - frequ(idec5) 149 : pentm = pentm + (icoe1*(pent5/ideca)) 150 : ndec = ndec + icoe1 151 : endif 152 : endif 153 : if (idec10.gt.0) then 154 : if (iexis(idec10).ne.0) then 155 : pent10 = fpet - frequ(idec10) 156 : pentm = pentm + (icoe2*(pent10 /(2.*ideca))) 157 : ndec = ndec + icoe2 158 : endif 159 : endif 160 : if (idec20.gt.0) then 161 : if (iexis(idec20).ne.0) then 162 : pent20 = fpet - frequ(idec20) 163 : pentm = pentm + (icoe3*pent20 / (4.*ideca)) 164 : ndec = ndec + icoe3 165 : endif 166 : endif 167 : cbp if (ndec.eq.0) then 168 : cbp write(6,*) 'ERREUR dans queshi.eso : contactez le support' 169 : cbp return 170 : cbp endif 171 : cbp fgra=fpet + (pentm * ienc) 172 : cbp 13/10/2010 : 173 : PENMIN = 3.E-4*fpet 174 : if ((ndec.ne.0.).and.(abs(pentm)).gt.PENMIN) then 175 : pentm = pentm/ndec 176 : else 177 : c pentm = imul * XPI * abs(fpet-shifti) 178 : pentm = imul * abs(fpet-shifti) 179 : write(6,*) 'DIFFICULTE dans QUESHI :', 180 : & ' calcul de la pente majorée ',pentm 181 : endif 182 : c on change completement la strategie en se placant juste apres fpet 183 : c fgra=fpet + (pentm * (min(ienc,2.))) 184 : c on revient a une strategie moins aggressive 185 : fgra=fpet + (pentm*ienc) 186 : if (iimpi.ge.6) then 187 : WRITE(6,*) 'pent5,pent10,pent20,pentm,fpet,fgra=' 188 : WRITE(6,*) pent5,pent10,pent20,pentm,fpet,fgra,imul 189 : endif 190 : Northo = max(4,(ienc/10)) 191 : 192 : * calcul du shift (cas sans trou ou avec un grand trou) 193 : 3 continue 194 : if (icle.eq.2) then 195 : az=fpet 196 : fpet=fgra 197 : fgra=az 198 : endif 199 : c fgra2= fgra*fgra 200 : c fpet2= fpet*fpet 201 : c b2= 4.d0*fpet2 202 : c quatac= -2.d0*( fgra2-fpet2) 203 : c delta=b2-quatac 204 : c if (delta.lt.0.D0) then 204 : c call erreur(5) 205 : c return 206 : c endif 207 : c aa=sqrt(delta) 208 : c x2= (-2.d0 * fpet + aa)/2.D0 209 : c shipro=x2 + fpet 210 : cbp : simplification 211 : * fmoy2 = (fgra2 + fpet2) / 2.D0 212 : * shipro = sqrt(fmoy2) 213 : shipro = (fgra + fpet) / 2.D0 214 : c WRITE(6,*) 'fpet,fgra,shipro=',fpet,fgra,shipro 215 : ccc fgra = (shipro + fgra)/2.D0 216 : c 217 : if (iimpi.ge.6) then 218 : WRITE(6,*) '----------------- Queshi -----------------' 219 : WRITE(IOIMP,1993) ienc,shipro 220 : 1993 FORMAT(2X,'=> ON DEMANDE ',I5,' MODES AUTOUR DE ',F12.3) 221 : endif 222 : c 223 : return 224 : c 225 : end 226 : 227 : 228 : 229 : 230 : 231 : 232 :
© Cast3M 2003 - All rights reserved.
Disclaimer