Télécharger comcho.eso

Retour à la liste

Numérotation des lignes :

  1. C COMCHO SOURCE BP208322 18/03/05 21:15:00 9771
  2. SUBROUTINE COMCHO
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8(A-H,O-Z)
  5. C
  6. C=======================================================================
  7. C
  8. C CALCUL DU NOMBRE DE CHOCS (syntaxe par defaut)
  9. C ou DES INDICES DE DEBUT DE CHOCS (syntaxe 'POSI')
  10. C DANS CHAQUE COURBE D'UN OBJET DE TYPE EVOLUTION.
  11. C LE RESULTAT EST UNE LISTENTI.
  12. C
  13. C SYNTAXE 1 : NCHO = COMT EVOL1 (DECL) ;
  14. C SYNTAXE 2 : NCHO (LMAX) (LDEB/LFIN) = COMT EVOL1 (DECL) ('MAXI') ('DEBU'/'FIN') ;
  15. C
  16. C NCHO : OBJET DE TYPE LISTENTI RESULTAT
  17. C EVOL : OBJET DE TYPE EVOLUTIO CONTENANT LES SIGNAUX A TRAITER
  18. C DECL : OBJET DE TYPE FLOTTANT % NIVEAU MAXI DES CHOCS
  19. C DEFINISSANT LE SEUIL D'ACQUISITION
  20. C NCHO : OBJET DE TYPE LISTENTI RESULTAT
  21. C
  22. C BP, 2016-05-02 : ajout syntaxe DEBU/FIN + on reecrit beaucoup
  23. C
  24. C=======================================================================
  25. C
  26. -INC CCOPTIO
  27. -INC SMEVOLL
  28. -INC SMLREEL
  29. -INC SMLENTI
  30. -INC CCREEL
  31. C
  32. PARAMETER (NBMOT=3)
  33. CHARACTER*4 LISMO(NBMOT)
  34. DATA LISMO/'DEBU','FIN','MAXI'/
  35. LOGICAL ZDEB,ZFIN,ZMAX,ZSEUIL
  36.  
  37.  
  38. C=======================================================================
  39. C LECTURE DES OBJETS EN ENTREE
  40. C=======================================================================
  41.  
  42. C EVOLUTION
  43. CALL LIROBJ('EVOLUTIO',IPEVO,1,IRET)
  44. IF(IERR.NE.0) RETURN
  45. MEVOLL=IPEVO
  46. SEGACT MEVOLL
  47. NC=IEVOLL(/1)
  48.  
  49. C SEUIL (EN %)
  50. CALL LIRREE(DECLEN,0,IDECL)
  51. IF(IERR.NE.0) RETURN
  52. IF(IDECL.EQ.0) THEN
  53. c sqrt(1.E-16)*100 ~ 1.E-6
  54. DECLEN=1.D-6
  55. ELSE
  56. CBP IF((DECLEN.LT.0.D0).OR.(DECLEN.GT.100.D0))THEN
  57. IF((DECLEN.LE.0.D0).OR.(DECLEN.GE.100.D0))THEN
  58. MOTERR(1:8)='DECLENCH'
  59. REAERR(1)=DECLEN
  60. REAERR(2)=0.D0
  61. REAERR(3)=100.D0
  62. CALL ERREUR(42)
  63. RETURN
  64. ENDIF
  65. DECLEN=MAX(DECLEN,(100.D0*XZPREC))
  66. ENDIF
  67.  
  68. C MOTS-CLES
  69. ZDEB=.FALSE.
  70. ZFIN=.FALSE.
  71. ZMAX=.FALSE.
  72. 10 IPLAC=0
  73. CALL LIRMOT (LISMO,NBMOT,IPLAC,0)
  74. IF(IERR.NE.0) RETURN
  75. IF(IPLAC.NE.0) THEN
  76. IF(IPLAC.EQ.1) ZDEB=.TRUE.
  77. IF(IPLAC.EQ.2) ZFIN=.TRUE.
  78. IF(IPLAC.EQ.3) ZMAX=.TRUE.
  79. GOTO 10
  80. ENDIF
  81.  
  82. C AIGUILLAGE
  83. IF(ZDEB.OR.ZFIN.OR.ZMAX) GOTO 200
  84.  
  85.  
  86. C=======================================================================
  87. C SYNTAXE 1
  88. C=======================================================================
  89.  
  90. JG=NC
  91. SEGINI MLENTI
  92. IPORE=MLENTI
  93.  
  94. C --- BOUCLE SUR LES COURBES ---
  95. DO 100 IC=1,NC
  96.  
  97. KEVOLL=IEVOLL(IC)
  98. SEGACT KEVOLL
  99. MLREEL=IPROGY
  100. SEGACT MLREEL
  101. L1=PROG(/1)
  102. C
  103. C CALCUL DU NIVEAU DE DECLENCHEMENT
  104. VMAX=0.D0
  105. DO 110 I=1,L1
  106. FORC=ABS(PROG(I))
  107. IF(FORC.GT.VMAX)VMAX=FORC
  108. 110 CONTINUE
  109. SEUIL=VMAX*DECLEN/100.D0
  110. IF(IIMPI.GE.1) WRITE(IOIMP,111)SEUIL
  111. 111 FORMAT(' SEUIL D''ACQUISITION : ',1PE12.5)
  112. C
  113. C COMPTE LE NOMBRE DE CHOCS
  114. NCHO=0
  115. FORC=ABS(PROG(1))
  116. ZSEUIL=FORC.GE.SEUIL
  117. DO 120 I=2,L1
  118.  
  119. FORC=ABS(PROG(I))
  120. IF(ZSEUIL) THEN
  121. * seuil deja depasse au pas precedent : on itere
  122. ZSEUIL=FORC.GE.SEUIL
  123. ELSE
  124. * on etait inferieur, et maintenant ?
  125. ZSEUIL=FORC.GE.SEUIL
  126. * on est sur un front montant
  127. IF(ZSEUIL) NCHO=NCHO+1
  128. ENDIF
  129.  
  130. 120 CONTINUE
  131. C
  132. C DESACTIVE TOUT
  133. SEGDES MLREEL
  134. SEGDES KEVOLL
  135.  
  136. C STOCKAGE DU NOMBRE DE CHOCS
  137. LECT(IC)=NCHO
  138. C
  139. 100 CONTINUE
  140. C --- FIN DE BOUCLE SUR LES COURBES ---
  141. SEGDES MEVOLL
  142. SEGDES MLENTI
  143.  
  144. C ECRITURE DU RESULTAT
  145. CALL ECROBJ('LISTENTI',IPORE)
  146. RETURN
  147.  
  148.  
  149. C=======================================================================
  150. C SYNTAXE 2
  151. C=======================================================================
  152.  
  153. 200 CONTINUE
  154.  
  155. c VERIF COMPATIBILITE
  156. IF(NC.GT.1) THEN
  157. MOTERR(1:8)='EVOLUTIO'
  158. INTERR(1:8)=IPEVO
  159. WRITE(IOIMP,*) 'ERREUR : COMT 2eme syntaxe :'
  160. CALL ERREUR(110)
  161. SEGDES MEVOLL
  162. RETURN
  163. ENDIF
  164.  
  165. IC=1
  166. KEVOLL=IEVOLL(IC)
  167. SEGACT KEVOLL
  168. MLREEL=IPROGY
  169. SEGACT MLREEL
  170. L1=PROG(/1)
  171.  
  172. c CREATION DE OBJETS DE SORTIE
  173. c OPTION DEBU/FIN
  174. JG=L1/2
  175. SEGINI MLENT1,MLENT2
  176. IPOR1=MLENT1
  177. IPOR2=MLENT2
  178. JG1=0
  179. JG2=0
  180. c OPTION MAXI
  181. JG=L1/2
  182. SEGINI,MLREE3
  183. IPOR3=MLREE3
  184. C
  185. C CALCUL DU NIVEAU DE DECLENCHEMENT
  186. VMAX=0.D0
  187. DO 210 I=1,L1
  188. FORC=ABS(PROG(I))
  189. IF(FORC.GT.VMAX)VMAX=FORC
  190. 210 CONTINUE
  191. SEUIL=VMAX*DECLEN/100.D0
  192. IF(IIMPI.GE.1) WRITE(IOIMP,111)SEUIL
  193. C
  194. C TROUVONS LES CHOCS
  195. NCHO=0
  196. FORC=ABS(PROG(1))
  197. ZSEUIL=FORC.GE.SEUIL
  198. VMAX=0.D0
  199. IF(ZSEUIL) VMAX=FORC
  200.  
  201. DO 220 I=2,L1
  202.  
  203. FORC=ABS(PROG(I))
  204. IF(ZSEUIL) THEN
  205. * seuil deja depasse au pas precedent
  206. VMAX=MAX(VMAX,FORC)
  207. ZSEUIL=FORC.GE.SEUIL
  208. IF(.NOT.ZSEUIL) THEN
  209. * on est sur un front descendant
  210. JG2=JG2+1
  211. MLENT2.LECT(JG2)=I
  212. MLREE3.PROG(JG2)=VMAX
  213. c On met 1 pour l'indice de debut si il n'existe pas
  214. c (cas du choc "a cheval" avec le bloc precedent)
  215. IF(JG1.EQ.0) THEN
  216. JG1=JG1+1
  217. MLENT1.LECT(JG1)=1
  218. ENDIF
  219. ENDIF
  220. ELSE
  221. * on etait inferieur, et maintenant ?
  222. ZSEUIL=FORC.GE.SEUIL
  223. * on est sur un front montant
  224. IF(ZSEUIL) THEN
  225. NCHO=NCHO+1
  226. JG1=JG1+1
  227. MLENT1.LECT(JG1)=I-1
  228. VMAX=FORC
  229. ENDIF
  230. ENDIF
  231.  
  232. 220 CONTINUE
  233. C on complete l'indice de fin avec L1 si il n'existe pas
  234. c (cas du choc "a cheval" avec le bloc suivant)
  235. IF(JG2.LT.JG1) THEN
  236. JG2=JG2+1
  237. MLENT2.LECT(JG2)=L1
  238. MLREE3.PROG(JG2)=VMAX
  239. ENDIF
  240. IF(JG1.NE.JG2) WRITE(IOIMP,*) 'PB AVEC LES DIMENSIONS !'
  241. JG=JG1
  242. SEGADJ,MLENT1,MLENT2,MLREE3
  243. C
  244. C DESACTIVE TOUT
  245. SEGDES MLREEL
  246. SEGDES KEVOLL
  247. C
  248. SEGDES MEVOLL
  249. SEGDES MLENT1,MLENT2
  250.  
  251. C ECRITURE DES RESULTATS
  252. c OPTION 'FIN'
  253. IF(ZFIN) THEN
  254. CALL ECROBJ('LISTENTI',IPOR2)
  255. ELSE
  256. SEGSUP,MLENT2
  257. ENDIF
  258. c OPTION 'DEBU'
  259. IF(ZDEB) THEN
  260. CALL ECROBJ('LISTENTI',IPOR1)
  261. ELSE
  262. SEGSUP,MLENT1
  263. ENDIF
  264. c OPTION 'MAXI'
  265. IF(ZMAX) THEN
  266. CALL ECROBJ('LISTREEL',IPOR3)
  267. ELSE
  268. SEGSUP,MLREE3
  269. ENDIF
  270. CALL ECRENT(NCHO)
  271. RETURN
  272.  
  273. END
  274.  
  275.  
  276.  
  277.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales