Télécharger maxin7.eso

Retour à la liste

Numérotation des lignes :

  1. C MAXIN7 SOURCE JC220346 16/06/16 21:15:02 8974
  2. C
  3. subroutine maxin7(ipoin1,ipoin2,ipoin3,montyp,kplus,labs)
  4. c-----------------------------------------------------------------------
  5. c
  6. C objet : min max entre n chpoints (n>1)
  7. c creation : bp, 2014-12-05
  8. c
  9. c-----------------------------------------------------------------------
  10.  
  11. implicit real*8(a-h,o-z)
  12. implicit integer (i-n)
  13. character*(8) montyp
  14.  
  15. -INC CCOPTIO
  16. -INC SMCHPOI
  17. -INC SMELEME
  18.  
  19. C-----INITIALISATION----------------------------------------------------
  20.  
  21. MCHPO1=ipoin1
  22. SEGINI,MCHPOI=MCHPO1
  23. ipoin3 = MCHPOI
  24. NSOUPO=IPCHP(/1)
  25. DO 101 ISOUPO = 1,NSOUPO
  26. MSOUP1 = IPCHP(ISOUPO)
  27. SEGINI,MSOUPO=MSOUP1
  28. NC=NOCOMP(/2)
  29. IPCHP(ISOUPO)=MSOUPO
  30. MPOVA1=IPOVAL
  31. SEGINI,MPOVAL=MPOVA1
  32. IPOVAL=MPOVAL
  33. 101 CONTINUE
  34.  
  35. c-----debut de boucle sur MCHPO2
  36. 1 MCHPO2=ipoin2
  37. SEGACT,MCHPO2
  38. NSOUP2=MCHPO2.IPCHP(/1)
  39. IF (NSOUP2.NE.NSOUPO) GOTO 990
  40.  
  41. DO 201 ISOUPO = 1,NSOUPO
  42.  
  43. MSOUPO = IPCHP(ISOUPO)
  44. MSOUP2 = MCHPO2.IPCHP(ISOUPO)
  45. SEGACT,MSOUP2
  46.  
  47. c --ON TESTE SI 2 EST TOUT PAREIL--
  48. IF(NOCOMP(/2).NE.NC) GOTO 991
  49. DO 211 IC=1,NC
  50. IF(NOCOMP(IC).NE.MSOUP2.NOCOMP(IC)) GOTO 991
  51. 211 CONTINUE
  52. IPT2=MSOUP2.IGEOC
  53. IF(IPT2.NE.IGEOC) THEN
  54. * on se donne une chance : meleme avec les meme noeuds dans le
  55. * meme ordre mais pointeurs differents
  56. MELEME=IGEOC
  57. SEGACT,MELEME,IPT2
  58. NBELEM=NUM(/2)
  59. IF(NBELEM.NE.IPT2.NUM(/2)) GOTO 992
  60. DO IB=1,NBELEM
  61. IF(NUM(1,IB).NE.IPT2.NUM(1,IB)) GOTO 992
  62. ENDDO
  63. SEGDES,MELEME,IPT2
  64. ENDIF
  65.  
  66. C --ON FAIT LE TRAVAIL--
  67. MPOVAL=IPOVAL
  68. N=VPOCHA(/1)
  69. MPOVA2=MSOUP2.IPOVAL
  70. SEGACT,MPOVA2
  71. IF( kplus.eq.1) THEN
  72. IF (labs.eq.0) THEN
  73. DO 301 j=1,NC
  74. DO 301 i=1,N
  75. VPOCHA(i,j)=MAX(VPOCHA(i,j),MPOVA2.VPOCHA(i,j))
  76. 301 CONTINUE
  77. ELSE
  78. DO 3010 j=1,NC
  79. DO 3010 i=1,N
  80. VPOCHA(i,j)=MAX(ABS(VPOCHA(i,j)),ABS(MPOVA2.VPOCHA(i,j)))
  81. 3010 CONTINUE
  82. ENDIF
  83. ELSE
  84. IF (labs.eq.0) THEN
  85. DO 302 j=1,NC
  86. DO 302 i=1,N
  87. VPOCHA(i,j)=MIN(VPOCHA(i,j),MPOVA2.VPOCHA(i,j))
  88. 302 CONTINUE
  89. ELSE
  90. DO 3020 j=1,NC
  91. DO 3020 i=1,N
  92. VPOCHA(i,j)=MIN(ABS(VPOCHA(i,j)),ABS(MPOVA2.VPOCHA(i,j)))
  93. 3020 CONTINUE
  94. ENDIF
  95. ENDIF
  96.  
  97. SEGDES,MSOUP2,MPOVA2
  98.  
  99. 201 CONTINUE
  100.  
  101.  
  102. call lirobj(montyp,ipoin2,0,iretou)
  103. if(iretou.ne.0) go to 1
  104.  
  105.  
  106. C-----FIN NORMALE-------------------------------------------------------
  107. DO 801 ISOUPO = 1,NSOUPO
  108. MSOUPO = IPCHP(ISOUPO)
  109. MPOVAL=IPOVAL
  110. SEGDES,MSOUPO,MPOVAL
  111. 801 CONTINUE
  112. SEGDES,MCHPOI
  113. RETURN
  114.  
  115.  
  116. C-----ERREUR------------------------------------------------------------
  117. 990 CONTINUE
  118. WRITE(IOIMP,*) 'NOMBRE DE ZONES DIFFERENT'
  119. WRITE(IOIMP,*) NSOUP2,NSOUPO
  120. GOTO 999
  121. 991 CONTINUE
  122. WRITE(IOIMP,*) 'COMPOSANTES DIFFERENTES'
  123. WRITE(IOIMP,*) NOCOMP(IC),' different de ',MSOUP2.NOCOMP(IC)
  124. GOTO 999
  125. 992 CONTINUE
  126. SEGDES,MELEME,IPT2
  127. WRITE(IOIMP,*) 'SUPPORTS GEOMETRIQUES DIFFERENTS'
  128. WRITE(IOIMP,*) IPT2,' different de ',IGEOC
  129. GOTO 999
  130. 999 CONTINUE
  131. CALL ERREUR(214)
  132. SEGSUP,MCHPOI
  133. SEGDES,MCHPO1,MCHPO2
  134. RETURN
  135.  
  136. END
  137.  
  138.  
  139.  
  140.  
  141.  
  142.  
  143.  

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