1 : C COMRED SOURCE FANDEUR 11/09/26 21:16:20 7141 2 : 3 : SUBROUTINE COMRED(ich1) 4 : 5 : *--------------------------------------------------------------- 6 : * reduit la taille d'un melval s'il est constant 7 : * 8 : * ich1 segment de type MELVAL (ACTIF en E/S) 9 : * segment modifie par ajustement si necessaire 10 : *--------------------------------------------------------------- 11 : 12 : IMPLICIT INTEGER(I-N) 13 : IMPLICIT REAL*8(A-H,O-Z) 14 : 15 : -INC SMCHAML 16 : 17 : melval = ich1 18 : segact,melval 19 : 20 : * Valeurs reelles : 21 : * ----------------- 22 : n1ptel = velche(/1) 23 : n1el = velche(/2) 24 : if (n1el.gt.1.or.n1ptel.gt.1) then 25 : vale1 = velche(1,1) 26 : ymaxe1 = 0. 27 : * Cas general : 28 : if (n1ptel.gt.1) then 29 : ymaxe2 = 0. 30 : * Est-on constant par element ? 31 : do ipel = 1, n1el 32 : valu1 = velche(1,ipel) 33 : ymaxd1 = 0. 34 : ymaxd2 = abs(valu1) 35 : do igel = 2, n1ptel 36 : diff1 = abs(velche(igel,ipel) - valu1) 37 : ymaxd1 = max(diff1,ymaxd1) 38 : ymaxd2 = max(abs(velche(igel,ipel)),ymaxd2) 39 : enddo 40 : * Est-on constant sur l'element ipel ? 41 : if (ymaxd1.gt.ymaxd2*1.d-14) goto 10 42 : diff1 = abs(valu1 - vale1) 43 : ymaxe1 = max(diff1,ymaxe1) 44 : ymaxe2 = max(abs(valu1),ymaxe2) 45 : enddo 46 : * Ici, on est a minima constant par element : 47 : n1ptel = 1 48 : * Est-on uniforme ? 49 : if (ymaxe1.le.ymaxe2*1.d-14) n1el = 1 50 : * Cas particulier : le champ est deja constant par element (n1ptel=1) 51 : else 52 : ymaxe2 = abs(vale1) 53 : do ipel = 2, n1el 54 : valu1 = velche(1,ipel) 55 : diff1 = abs(valu1 - vale1) 56 : ymaxe1 = max(diff1,ymaxe1) 57 : ymaxe2 = max(abs(valu1),ymaxe2) 58 : enddo 59 : * Est-on uniforme ? 60 : if (ymaxe1.gt.ymaxe2*1.d-14) goto 10 61 : n1el = 1 62 : endif 63 : n2ptel = 0 64 : n2el = 0 65 : segadj,melval 66 : * On reactive le segment pour enlever le statut *mod suite au segadj 67 : segact,melval 68 : 10 continue 69 : endif 70 : 71 : * Valeurs de type pointeur : 72 : * -------------------------- 73 : n2ptel = ielche(/1) 74 : n2el = ielche(/2) 75 : if (n2el.gt.1.or.n2ptel.gt.1) then 76 : jalu1 = ielche(1,1) 77 : maxd1 = 0 78 : * Cas general : 79 : if (n2ptel.gt.1) then 80 : do ipel = 1, n2el 81 : jalu2 = ielche(1,ipel) 82 : * Est-on constant sur l'element ipel ? 83 : maxd2 = 0 84 : do igel = 2, n2ptel 85 : jiff = abs(ielche(igel,ipel) - jalu2) 86 : maxd2 = max(jiff,maxd2) 87 : enddo 88 : if (maxd2.ne.0) goto 20 89 : jiff = abs(jalu2 - jalu1) 90 : maxd1 = max(jiff,maxd1) 91 : enddo 92 : * Ici, on est a minima constant par element : 93 : n2ptel = 1 94 : * Est-on uniforme ? 95 : if (maxd1.eq.0) n2el = 1 96 : * Cas particulier : le champ est deja constant par element (n2ptel=1) 97 : else 98 : do ipel = 2, n2el 99 : jalu2 = ielche(1,ipel) 100 : jiff = abs(jalu2 - jalu1) 101 : maxd1 = max(jiff,maxd1) 102 : enddo 103 : * Est-on uniforme ? 104 : if (maxd1.gt.0) goto 20 105 : n2el = 1 106 : endif 107 : n1ptel = 0 108 : n1el = 0 109 : segadj,melval 110 : * On reactive le segment pour enlever le statut *mod suite au segadj 111 : segact,melval 112 : 20 continue 113 : endif 114 : 115 : ich1 = melval 116 : 117 : RETURN 118 : END 119 : 120 :
© Cast3M 2003 - All rights reserved.
Disclaimer