
C     CRISIS INCLUDED WITH SEISAN
c**************************************************************
c This are obsolete metacommands, needed when compiling with 
c MS-FORTAN 5
c$large
c$DEBUG   
c**************************************************************
	
c
c   changes
c
c   june 99 by jh : --------------   version 7.0 ----------------
c                   use seisan unix-pc date routines
c                   use variable input file name
c                   open(26+I changed from binary to unformatted
c   june 13, 99 lo: replaced in write statement \ by `\'
c                   removed the AUTOMATIC declaration
c   sep 17      jh: replace '\' by  - , did not compile on pc
c   sep 24      lo: put AUTOMATIC back in
c**************************************************************
C   This block is to be used when constructing a DLL
C      INTEGER FUNCTION CRISIS () 
C!MS$ATTRIBUTES ALIAS:'CRISIS' :: CRISIS
C!MS$ATTRIBUTES DLLEXPORT :: CRISIS
C**************************************************************


C**************************************************************
C   This lines for a standalone CRISIS
c     PROGRAM CRISIS
C**************************************************************


C**************************************************************
C
C     PROGRAM FOR COMPUTING SEISMIC RISK
C     March, 1992
C     MARIO ORDAZ. NATIONAL AUTONOMOUS UNIVERSITY OF MEXICO
C
c     Modificado en mayo-junio de 1998 por M Ordaz, J Arboleda y
c     A Aguilar
c
c********************************************************************  




c********************************************************************
c
c   seisan time strings
c
      character*12 t1
      character*14 t2
 
c
c               Dimensiones máximas de los arreglos  
c
      INTEGER MODMAX,NCMAX,NTMAX,NREGMAX,NMAGMAX,NRMAX,NMCX,NMMAX
      INTEGER NTRIMAX,NVMAX,NPGMAX,NVGMAX
c
      PARAMETER (MODMAX=5,NCMAX=20,NTMAX=15,NREGMAX=200,NMAGMAX=10,
     .           NRMAX=21,NMCX=4000,NMMAX=30,NVMAX=25,
     .           NTRIMAX=NREGMAX*NVMAX,NPGMAX=10,NVGMAX=30)     
     
C
c     MODMAX:  No. maximo de modelos de atenuacion
C     NCMAX :  No. de aceleraciones de calculo
C     NTMAX :  No. de periodos estructurales
c     NREGMAX: No. de fuentes
c     NMAGMAX: No. de magnitudes en la tabla de atenuacion
c     NRMAX  : No. de distancias en la tabla de atenuacion
c     NMCX   : No. de distancias en una fuente
c     NMMAX  : No. de magnitudes para integraci¢n
c     NTRIMAX: No. total de triangulos para todas las regiones
c     NVMAX  : No. de vertices para un poligono
c     NPGMAX : No. de polígonos de reducción de malla
c     NVGMAX : No. de vértices de poligonos de malla 
C
c********************************************************************

      REAL MU(10),MU1(10),WM(10),WM1(10)  
      REAL B(10),WB(10)
      REAL A0(NCMAX),AU(NCMAX),DA(NCMAX)
      REAL T(NTMAX),COEF(NTMAX)
      REAL EVP(NCMAX,NTMAX),ANU(NCMAX,NTMAX) 
      
      REAL RR

      REAL VECT(NCMAX)
      REAL MINF,MMAX,MAG,M0,MBP

      REAL LAS,LOS,LAI,LOI
      REAL PARSIS(NREGMAX,9)
      REAL VB(5),SUMA
      INTEGER NBIN(5)
      INTEGER IC(NREGMAX),IE(NREGMAX),IMO(NREGMAX)
      
      INTEGER ANO,MES,DIA,DIAdos 
 
      CHARACTER*80 TITGEN,BASURA
      CHARACTER*80 TITULO(NREGMAX)
      CHARACTER*200 ARCHEN,ARCHSAL,ARCHGRA,ARCHBAS,ARCHMA
	CHARACTER*200 FN
      CHARACTER*200 MODELO(MODMAX)
	CHARACTER*2 NUM2
	CHARACTER*1 NUM1
      REAL T00


      REAL ACEL,DMAG,DRAD,SLA,RINF,DDLA,DDLO,DRADOR,WAMAX
      INTEGER NMAG,NRAD,NLA,NLO
C
      REAL VER,DM,RMAX
      REAL DIST,EB,CB,EMU,SMU,SM

      REAL SEM,SEM2,BL,AMBP,EL0,C,AMED,CALACA,FG1,FG2,FNORAC,PM
      REAL WQ1,WQ2,EMT,D,F,SMT,AMU,AME,AK,CEF
      REAL TE,A1,A2,ANU1,ANU2,EME,TREG,SECS,TSITIO,TTOTAL

      INTEGER NREG,NREGP,NREGC,NMOD,NT,NA,NM,NB,NBBM,NREF,IMG
      INTEGER I,J,K,L,N,IA,IB,ILAT,ILON,NR,JINC,IT,IR,IM
      INTEGER NUBAN
        
      REAL DISTA,ZC,AREA3D,VLM1 
      
      INTEGER LONGFILE
      
      REAL TR(5)
C
C     *******************************************
C     NUEVAS VARIABLES P/TRIANGULOS
      INTEGER NS(NREGMAX),POSI(NREGMAX)
      REAL XYS(3,NVMAX) 
      INTEGER KI,KF,NBAN,KBAN
      INTEGER ANS(1)
      REAL AREA(NMCX)  
      INTEGER NTRI    
c     ---- Arreglos general y local de triangulos
      REAL XYTRI (1:3,1:3,1:NTRIMAX)
      REAL LOCTRI(1:3,1:3,1:NVMAX)
      REAL FMIN,RMIN
      REAL XSITE,YSITE,WPESO,HSITE       
      INTEGER KTR

c     Nuevas variables para archivos graficos para cada periodo estructural  
      CHARACTER*200 ARCHGRAT(NTMAX)
	REAL NULO

c	NUEVAS VARIABLES REDUCCION MALLA
	INTEGER NPOLGRID

C	MAXIMO NPGNMAX POLIGONOS Y NVGMAX VERTICES POR POLIGONO	 
	DOUBLE PRECISION LATGRID(NPGMAX,NVGMAX),LONGGRID(NPGMAX,NVGMAX)
	DOUBLE PRECISION NVERGRID(NVGMAX)
	INTEGER NVERG
      DOUBLE PRECISION VCLGRID(2,NVGMAX),PT(2)		 
	INTEGER IGRID,JGRID,INOUT
	INTEGER PUNTOSMA,NREFTOT
                                       
C     *********************************************************************
c
c                                  COMMONS
c
      COMMON/ATENUA/ACEL(MODMAX,NTMAX,NMAGMAX,NRMAX),SLA(MODMAX,NTMAX),
     1              MINF(MODMAX),DMAG(MODMAX),RINF(MODMAX),DRAD(MODMAX),
     2              NMAG(MODMAX),NRAD(MODMAX),WAMAX(MODMAX,NTMAX)
c     
      COMMON/TRIAN/KTR,RR(NMCX),WPESO(NMCX),XSITE,YSITE,HSITE,RMAX,
     *             RMIN,FMIN
c
C     *********************************************************************

C     *********************************************************************
c
c                    DATAS
c
      DATA VER/99.1/
c     ---- Datos p/subdivision de triangulos
      DATA FMIN,RMIN / 3.0,11.0/
C     ----  Concentraciones distribucion normal ----------
      DATA MU1/-4.859,-3.581,-2.484,-1.466,-0.4849,0.4849,
     1         1.466,2.484,3.581,4.859/                         
      DATA WM1/0.000004311,0.0007581,0.01911,0.1355,
     1         0.3446,0.3446,0.1355,0.01911,0.0007581,0.000004311/
c     ----  Numero de concentraciones NB 
      DATA NB/2/
c     ----  Intervalos DM para integrar con respecto a la magnitud      
      DATA NM/10/
     	DATA NULO/0.0/
C     **********************************************************************

c     **********************************************************************


c
c print version
c
      include 'version.inc'
      out_version_date='July 23, 2001'
      if (version_new) out_version_date=version_date
      call print_ver

 	TTOTAL=0

C     WHEN BUILDING A DLL UNCOMMENT FOLLOWING LINE:
C      CRISIS=0

	NREFTOT=0
	PUNTOSMA=0

	FN='filename.nam'
	 
C     LECTURA DEL NOMBRE DEL ARCHIVO DE DATOS (*.dat)
      write(6,*)' Input file name'
      read(5,'(a)') archen
c     OPEN(25,FILE=FN,STATUS='old',err=2101)
c     READ(25,'(A)') ARCHEN
      write(6,*)' Output file name without extension like out'
      read(5,'(a)') archbas

C     LECTURA DEL NOMBRE BASE PARA LOS ARCHIVOS DE RESULTADOS 
c     READ(25,'(A)') ARCHBAS
c     CLOSE(25)

C     THIS LINE COMPUTES THEN LENGTH OF STRING ARCHBAS, WITHOUT
C     TRAILING BLANKS
      LONGFILE=OURLEN(ARCHBAS)
	I=LONGFILE+1
C     ******************************************************************** 


C     ******************************************************************** 
C     APERTURA DE ARCHIVOS
      OPEN(15,FILE=ARCHEN,STATUS='OLD')   

      ARCHSAL=ARCHBAS(1:I-1)//'.res'
      CALL ABRIR (16,ARCHSAL)

      ARCHGRA=ARCHBAS(1:I-1)//'.gra'
      CALL ABRIR (7,ARCHGRA) 

      ARCHMA=ARCHBAS(1:I-1)//'.map'
      CALL ABRIR (9,ARCHMA)
c     *********************************************************************

C     This function gets the system date 
c     CALL GETDAT (ANO,MES,DIA)
c
c   seisan date insteqd of pc data only
c
      call systime(t1,t2)
      read(t1,'(3i2)') ano,mes,dia
 
      READ (15,'(A80)') TITGEN
	READ (15,*) NREG,NMOD,NT,NA  
      WRITE(16,6000) VER,TITGEN,ANO,MES,DIA
      WRITE(16,6135) MODMAX,NCMAX,NTMAX,NREGMAX,NMAGMAX,NRMAX,NMCX     
      WRITE(16,6001) NREG,NMOD,NT,NA,NM

C     REVISA VALORES MAXIMOS DE LOS PARAMETROS
      IF (NREG .GT. NREGMAX .OR. NMOD .GT. MODMAX .OR.
     .    NT   .GT. NTMAX   .OR. NA   .GT. NCMAX  .OR. 
     .    NM   .GT. NMMAX) THEN
          WRITE(16,*) 'ALGUN PARAMETRO EXCEDE EL VALOR MAXIMO'
		CALL CIERRA()
C		CRISIS=2
C		RETURN
C         STOP
      ENDIF
C    
      WRITE( 9,6000) VER,TITGEN,ANO,MES,DIA
      WRITE( 7,6000) VER,TITGEN,ANO,MES,DIA
	WRITE(7,9070)


      DO 1 I=1,NT
          READ(15,*) T(I),A0(I),AU(I)
          WRITE(16,6010) I,T(I),A0(I),AU(I),NA
          A0(I)=LOG(A0(I))
          AU(I)=LOG(AU(I))
          DA(I)=( AU(I)-A0(I) )/(NA-1)
C         LECTURA DE NOMBRES DE ARCHIVOS.GRA PARA CADA PERIODO
          IF (I .LT. 10) THEN
             WRITE(NUM1,'(I1)') I
             ARCHGRAT(I)=ARCHBAS(1:LONGFILE)//'.B'//NUM1
		ELSE
		   WRITE(NUM2,'(I2)') I
             ARCHGRAT(I)=ARCHBAS(1:LONGFILE)//'.B'//NUM2
		ENDIF   	
c         OPEN(26+I,FILE=Archgrat(I),STATUS='UNKNOWN',FORM='BINARY')
          OPEN
     *    (26+I,FILE=Archgrat(I),STATUS='UNKNOWN',FORM='unformatted')
1     CONTINUE

C     LECTURA DE RMAX Y PERIODOS PARA CALCULO DE TASAS DE EXCEDENCIA FIJAS 
      READ (15,*) RMAX,(TR(I),I=1,5)
	WRITE(9,9050)
      WRITE(9,9060) (TR(I),I=1,5)
	WRITE(16,6020) RMAX

C     LECTURA DE MALLA DE PUNTOS
	READ (15,*) LOI,LAI,DDLO,DDLA,NLO,NLA
	WRITE(16,6024)
      WRITE(16,6025) LOI,LAI,DDLO,DDLA,NLO,NLA

C     NUEVOS DATOS MALLA
	READ (15,*) NPOLGRID
	IF (NPOLGRID.GT.0) THEN
	  IF (NPOLGRID .GT. NPGMAX) THEN
	     WRITE(16,*) 'ERROR: NPOLGRID>NPGMAX'
	     CALL CIERRA ()
C		 CRISIS=3
C		 RETURN
C		 STOP 'ERRORS IN GENERAL DATA FILE'
	  ENDIF
	  WRITE(16,6026)
	  WRITE(16,6027) NPOLGRID 
	END IF

	DO I=1,NPOLGRID
        READ(15,*) NVERGRID(I)
	  WRITE(16,6028)NVERGRID(I) 
        IF (NVERGRID(I) .GT. NVGMAX) THEN
	     WRITE(16,*) 'ERROR: NVERGRID>NVGMAX'
		 CALL CIERRA()
C  		 CRISIS=4
C		 RETURN
C		 STOP 'ERRORS IN GENERAL DATA FILE'
	  ENDIF
	  WRITE(16,6029)
     	  DO J=1,NVERGRID(I)
           READ(15,*) LATGRID(I,J),LONGGRID(I,J)
           WRITE(16,6030) LATGRID(I,J),LONGGRID(I,J)
        END DO
	END DO
C      
C
C     ******************** LECTURA DE MATRIZ DE ATENUACION  ************
      WRITE (16,6810)
      DO 700 I=1,NMOD
         READ (15,'(A200)') MODELO(I)
         OPEN (8,FILE=MODELO(I),STATUS='OLD')
         READ (8,*) MINF(I),MMAX,NMAG(I)
         DMAG(I)=(MMAX-MINF(I))/(NMAG(I)-1)
         READ (8,*) RINF(I),MMAX,NRAD(I)
         WRITE (16,6820) I,MODELO(I)
	   WRITE (16,6821)
	   WRITE(16,6825) NMAG(I),MINF(I),DMAG(I)
	   WRITE(16,6822)
	   DRADOR=(MMAX-RINF(I))/(NRAD(I)-1)
	   WRITE(16,6826) NRAD(I),RINF(I),DRADOR
	   RINF(I)=ALOG(RINF(I))
	   MMAX=ALOG(MMAX)
         DRAD(I)=(MMAX-RINF(I))/(NRAD(I)-1)   
         DO 680 J=1,NT 
           READ(8,*) MMAX,SLA(I,J),WAMAX(I,J)
           DO 601 K=1,NMAG(I)
             READ (8,*,ERR=2200) (ACEL(I,J,K,L),L=1,NRAD(I))
601        CONTINUE
680      CONTINUE
         CLOSE (8)
700   CONTINUE

      WRITE (16,6830)             
      DO 710 J=1,NT               
        WRITE (16,6840) J,(SLA(I,J),I=1,NMOD)
710   CONTINUE      
      WRITE (16,6850)             
      DO 720 J=1,NT               
        WRITE (16,6840) J,(WAMAX(I,J),I=1,NMOD)
720   CONTINUE                  
C     ******************************************************************      



C     ********************  LECTURA DE DATOS DE SISMICIDAD  ************
C     Se leen tambien los datos de localizaci¢n y se triangula cuando
c     procede

      NREGP=0
      NREGC=0

c     En NUMTRI llevamos cuenta de los triangulos,lineas o puntos que 
C     se tengan. KI y KF son los contadores de posici¢n de puntos,
C     l¡neas o triangulos
      KI=0
      KF=0
      NBAN=0

	WRITE (16,6066) 


      DO 1000 N=1,NREG   

        KBAN=0
        READ(15,'(A80)') TITULO(N)
        READ (15,*) IC(N),IE(N),IMO(N)
c       ---- IE=0,Poligono; IE=1,polilinea; IE=2, punto

        IF(IC(N) .EQ.1) THEN
           NREGP=NREGP+1                         
        ELSE
          NREGC=NREGC+1
        ENDIF                

        READ(15,*) NS(N)
C       SI EL NUMERO DE VERTICES SUPERA AL LIMITE REALIZA LECTURA
C       PERO SE BRINCARA AL POLIGONO FORMADO POR DICHOS VERTICES        
        IF (NS(N) .GT. NVMAX) THEN
           NBAN=NBAN+1
           KBAN=1
           DO I=1,NS(N)
             READ(15,'(A80)') BASURA
           ENDDO
        ELSE
           DO I=1,NS(N)        
             READ (15,*) XYS(1,I),XYS(2,I),XYS(3,I)
           ENDDO 
        ENDIF

c       ESCRITURA DE DATOS DE LAS FUENTES
        WRITE (16,6067) N,TITULO(N)

C	  IC=1 POISSON MODEL
	  IF (IC(N).EQ.1) THEN
	      WRITE (16,9010)
	  ELSE
	      WRITE	(16,9015)
	  END IF

C	  IE=0 AREA SOURCE IE=1 FAULT SOURCE IE=2 POINT SOURCE
	  IF (IE(N).EQ.0) WRITE (16,9020)
        IF (IE(N).EQ.1) WRITE (16,9025)
        IF (IE(N).EQ.2) WRITE (16,9030)

C       IMO= NUMBER OF ATTENUATION MODEL
	  WRITE(16,9035) MODELO(IMO(N))

C       NS=NUMBER OF VERTEX
	  WRITE(16,9040) NS(N)
        WRITE (16,6071) 
        IF (KBAN .EQ. 1) THEN
           WRITE (16,1100) N,NVMAX 
        ELSE
           DO I=1,NS(N)
             WRITE (16,6072) XYS(1,i),XYS(2,i),XYS(3,I)
           ENDDO
        ENDIF                         
      
        IF (KBAN .EQ. 0) THEN

           POSI(N)=KI+1

           IF (IE(N) .EQ. 0) THEN
              ANS(1)=NS(N)
              CALL TRIANGULATE(1,NS(N),ANS,XYS,NTRI,LOCTRI)
              IF (NTRI.NE.NS(N)-2)THEN
                NBAN=NBAN+1
                WRITE(16,*)'ERROR EN LA GEOMETRIA DE LA FUENTE',N
              ENDIF
              AREA(N)=0.0
              DO I=1,NTRI
C			  WRITE(16,*) '  '                                    
                DO J=1,3
                   XYTRI(1,J,I+KI)=LOCTRI(1,J,I)
                   XYTRI(2,J,I+KI)=LOCTRI(2,J,I)
                   XYTRI(3,J,I+KI)=LOCTRI(3,J,I)
C           	   WRITE(16,'(3(F10.3,2X))') (XYTRI(K,J,I+KI),K=1,3)
                ENDDO 
c               CALCULO DEL AREA DE CADA TRIANGULO PARA OBTENER EL
C               AREA DEL POLIGONO, QUE SE ASIGNA A AREA(N)
                VLM1=AREA3D(LOCTRI(1,1,I),LOCTRI(2,1,I),LOCTRI(3,1,I),
     .                      LOCTRI(1,2,I),LOCTRI(2,2,I),LOCTRI(3,2,I),
     .                      LOCTRI(1,3,I),LOCTRI(2,3,I),LOCTRI(3,3,I))
                AREA(N)=AREA(N)+VLM1
C		  IF (AREA(N) .EQ. 0) THEN
C        		WRITE(16,*)'ERROR EN LA GEOMETRIA DE LA FUENTE',N
C				NBAN=NBAN+1
C		  ENDIF
              ENDDO
C             *****************************************************  

           ELSE 

              IF ( IE(N) .EQ. 1) THEN

C             *****************************************************  
c                UNA POLILINEA            
                 NTRI=NS(N)-1
                 AREA(N)=0.0
                 DO I=1,NTRI 
                    XYTRI(1,1,I+KI)=XYS(1,I)
                    XYTRI(1,2,I+KI)=XYS(1,I+1)
                    XYTRI(2,1,I+KI)=XYS(2,I)
                    XYTRI(2,2,I+KI)=XYS(2,I+1)      
                    XYTRI(3,1,I+KI)=XYS(3,I)
                    XYTRI(3,2,I+KI)=XYS(3,I+1)                      
C                   CALCULO DE LA LONGITUD TOTAL DE LA LINEA 
                    ZC=ABS(XYTRI(3,1,I+KI)-XYTRI(3,2,I+KI))   
                    DISTA=DIST(XYTRI(2,1,I+KI),XYTRI(1,1,I+KI),
     +                         XYTRI(2,2,I+KI),XYTRI(1,2,I+KI),ZC)  
                    AREA(N)=AREA(N)+DISTA
                 ENDDO         
C             *****************************************************  
                 
              ELSE

C             *****************************************************  
C                PUNTOS
                 NTRI=NS(N)
                 AREA(N)=NS(N)
                 DO I=1,NTRI
                    XYTRI(1,1,I+KI)=XYS(1,I)
                    XYTRI(2,1,I+KI)=XYS(2,I)
                    XYTRI(3,1,i+KI)=XYS(3,I)
                 ENDDO

              ENDIF

           ENDIF

           KI=KI+NTRI

        ENDIF  
        
        IF (IC(N) .EQ. 1) THEN        
C          LECTURA DE DATOS DE SISMICIDAD DE MODELO DE POISSON
           READ (15,*) (PARSIS(N,I),I=1,7)  
        ELSE
C          LECTURA DE DATOS DE SISMICIDAD DE MODELO CARACTERISTICO
           READ (15,*) (PARSIS(N,I),I=1,7)  
        END IF


1000  CONTINUE

      IF (NBAN .NE. 0) THEN
	  write(16,*) '  '	
	  write(16,*) '*************************************'	
        WRITE(16,*) 'LA CORRIDA NO PUEDE CONTINUAR POR'
	  WRITE(16,*) 'ERRORES EN ALGUNOS DATOS DE GEOMETRIA'
	  write(16,*) '*************************************'	
	  CALL CIERRA ()
C	  CRISIS=5
C	  RETURN
C       STOP ' ERRORES DE GEOMETRIA'
      ENDIF
         
                   

C     *********************************************************************
C     ESCRIBE SISMICIDAD DE POISSON
      IF (NREGP .GT. 0) THEN
	  WRITE(16,6039)
	  WRITE(16,6035)
        WRITE (16,6040)
        DO 1130 N=1,NREG
          IF (IC(N) .EQ. 1) WRITE (16,6041) N,(PARSIS(N,I),I=1,7)
1130    CONTINUE
      ENDIF 

C     ESCRIBE SISMICIDAD CARACTERISTICA
      IF (NREGC .GT. 0) THEN
	  WRITE(16,6044)
	  WRITE(16,6042)
        WRITE(16,6045)
        DO 1140 N=1,NREG
          IF (IC(N) .NE. 1) WRITE (16,6046) N,(PARSIS(N,I),I=1,7)
1140    CONTINUE
      ENDIF
C     ******************************************************************
c
c
C     ***************   INICIA CALCULOS  *******************************
C                                                    
      DO 2000 ILAT=1,NLA

          LAS=LAI+(ILAT-1)*DDLA
		PT(2)=LAS
C           
          DO 1900 ILON=1,NLO

            LOS=LOI+(ILON-1)*DDLO
		  PT(1)=LOS
            TSITIO=SECS()

		  WRITE(*,1001) LOS,LAS
C	REVISA SI ESTE PUNTO DE LA MALLA SE DEBE CALCULAR

		  DO IGRID=1,NPOLGRID
			NVERG=NVERGRID(IGRID)
			DO JGRID=1,NVERG
				VCLGRID(1,JGRID)=LATGRID(IGRID,JGRID)
				VCLGRID(2,JGRID)=LONGGRID(IGRID,JGRID)
		    END DO
	        CALL POLINS(NVERG,VCLGRID,PT,INOUT)
C			INOUT=0 EL PUNTO ESTA EN EL LIMITE DEL POLIGONO
C			INOUT=1 EL PUNTO ESTA DENTRO DEL POLIGONO
C			INOUT=-1 EL PUNTO ESTA FUERA DEL POLIGONO
C			INOUT=-2 ERROR EN PARAMETROS
C             SI EL PUNTO ESTA DENTRO, VA A HACER CALCULOS 
			IF (INOUT.EQ.0.OR.INOUT.EQ.1) THEN
			   GOTO  135
			ELSE
				DO IT=1,NT
					DO IA=1,NA
C					ASIGNA AL PUNTO QUE NO SE CALCULO INTENSIDAD=0 PARA FINES
C					DE GENERACION DE MAPAS DE PELIGRO CON CRISIS98 PARA WINDOWS	
					    WRITE(26+IT)NULO
 					END DO
 				END DO
				GOTO 1900			  
			ENDIF

			IF (INOUT.EQ.-2) THEN
C         
C		 		WHEN BUILDING A DLL, UNCOMMENT FOLLOWING LINES
C 				CRISIS=6
				CALL CIERRA()
c 				RETURN
C
C				WHEN BUILDING A STANDALONE, UNCOMMENT FOLLOWING LINE
C               STOP 'ERRORS IN GENERAL DATA FILE'       
		 
			ENDIF

		  END DO

135		  CONTINUE


            WRITE (16,6500) LOS,LAS
	      PUNTOSMA=PUNTOSMA+1
            WRITE (16,6550) PUNTOSMA
            WRITE (16,6610)
		
            DO 138 I=1,NA                                                
            DO 138 J=1,NT
138         ANU(I,J)=0.0
C                                          
            DO 1800 N=1,NREG

               TREG=SECS()

               DO 137 I=1,NA
               DO 137 J=1,NT
137            EVP(I,J)=0.0
C          
C              ASIGNACION A VARIABLES GLOBALES DE SUBDIVISION
               KTR=0
               XSITE=LOS
               YSITE=LAS

C              ***********************************************************
C              SUBDIVIDE OBJETOS

               IF (IE(N) .EQ. 0) THEN

c                 ****************************************************
c                 SE TRATA DE UNA AREA:  
                  KI=POSI(N)
                  KF=KI+(NS(N)-2)-1
                  DO I=KI,KF     
                    CALL DIVREC( XYTRI(1,1,I),XYTRI(2,1,I),XYTRI(3,1,I),
     +                           XYTRI(1,2,I),XYTRI(2,2,I),XYTRI(3,2,I),
     +                           XYTRI(1,3,I),XYTRI(2,3,I),XYTRI(3,3,I))
                  ENDDO
c                 ****************************************************

               ELSE

                  IF (IE(N) .EQ. 1) THEN

c                 ****************************************************
C                   SE TRATA DE UNA LINEA
                    KI=POSI(N)
                    KF=KI+(NS(N)-1)-1
                    DO I=KI,KF
                     CALL DIVLIN(XYTRI(1,1,I),XYTRI(2,1,I),XYTRI(3,1,I),
     +                           XYTRI(1,2,I),XYTRI(2,2,I),XYTRI(3,2,I))
                    ENDDO
c                 ****************************************************

                  ELSE

c                 ****************************************************
C                   SE TRATA DE PUNTOS
                    KI=POSI(N)
                    KF=KI+(NS(N))-1
                    DO I=KI,KF     
                      DISTA=DIST(XYTRI(2,1,I),XYTRI(1,1,I),YSITE,XSITE,
     .                           XYTRI(3,1,I))
                      IF(DISTA.LT.RMAX)THEN   
                         KTR=KTR+1
                         RR(KTR)=DISTA
                         WPESO(KTR)=1.0
                      ENDIF
                    ENDDO
                  ENDIF
               ENDIF     
C              ***********************************************************
C
               NR=KTR
               DO I=1,NR      
C                AREA SUBFUENTES/AREA FUENTE      
                 WPESO(I)=WPESO(I)/AREA(N)
               ENDDO                  
c
               IF (IC(N) .EQ. 1) THEN

C                *************** PROCESO DE POISSON ********************
                 EL0=PARSIS(N,1)
                 EB=PARSIS(N,2)
                 CB=PARSIS(N,3)
                 EMU=PARSIS(N,4)
                 SMU=PARSIS(N,5)
                 MMAX=PARSIS(N,6)
                 M0=PARSIS(N,7)
C
C                ***************  CONCENTRACIONES PARA  Mu ************
                 SM=0.
                 DO 110 J=1,10     
                    MU(J)=MU1(J)*SMU+EMU
                    IF( MU(J) .LT. MMAX .OR. MU(J) .LT. M0 ) THEN
                      WM(J)=0.
                    ELSE 
                       WM(J)=WM1(J)
                    ENDIF
                    SM=SM+WM(J)
 110             CONTINUE
C
                 NBBM=0
                 SEM=0.
                 SEM2=0.
                 DO 120 J=1,10
                    WM(J)=WM(J)/SM
                    SEM=SEM+MU(J)*WM(J)
                    SEM2=SEM2+MU(J)*MU(J)*WM(J)
                    IF (WM(J) .NE. 0.00 .AND. NBBM .EQ. 0) THEN
                      JINC=J
                      NBBM=1
                    ENDIF
 120             CONTINUE
                 IF (SMU .EQ. 0.0) THEN
                   JINC=10
                   WM(10)=1.0
                 ENDIF
                 SEM2=SEM2-SEM*SEM
                 IF (SEM2 .LT. 0.) SEM2=0.0
                 SEM2=SQRT(SEM2)
C
C                ***************  CONCENTRACIONES PARA á ************
                 IF(CB .LE. 0.1) NB=1
                 IF (NB .LE. 1) THEN
                   NB=1
                   B(1)=EB
                   WB(1)=1.0
                 ELSE
                   MBP=1./CB/CB
                   BL=MBP/EB
                   AMBP=MBP
                   CALL LAGUER (NB,AMBP,BL,B,WB)
                 ENDIF
C
C               *************** INICIA EL PROCESO DE INTEGRACION *****


                 DO 670 IT=1,NT
                   NREF=NR
                   CALL CERO (VECT,NA)
                   DO 650 IR=1,NR
c	              Write(16,9095) RR(IR)
                      DO 640 IB=1,NB
                        DO 630 IM=JINC,10
                          DM=(MU(IM)-M0)/(NM-1)

                          DO 160 IA=1,NA

                            C=A0(IT)+(IA-1)*DA(IT)
                            C=EXP(C)
                            AMED=CALACA(IMO(N),IT,MU(IM),RR(IR))
 	               FG1=FNTRUNC(C,AMED,WAMAX(IMO(N),IT),SLA(IMO(N),IT))
                            FG2=PM(MU(IM),M0,B(IB),MU(IM))
                            WQ1=FG1*FG2
                            AMED=CALACA(IMO(N),IT,M0,RR(IR))
   	               FG1=FNTRUNC(C,AMED,WAMAX(IMO(N),IT),SLA(IMO(N),IT))
                            FG2=PM(M0,M0,B(IB),MU(IM))
                            WQ2=FG1*FG2
                            VECT(IA)=VECT(IA)+
     1                      (WQ2+WQ1)*WB(IB)*WM(IM)*DM*WPESO(IR)

                            DO 140 IMG=2,NM-1
                              MAG=M0+(IMG-1)*DM
                              AMED=CALACA(IMO(N),IT,MAG,RR(IR))
 	               FG1=FNTRUNC(C,AMED,WAMAX(IMO(N),IT),SLA(IMO(N),IT))
                              FG2=PM(MAG,M0,B(IB),MU(IM))
                              WQ2=FG1*FG2
                              VECT(IA)=VECT(IA)+
     1                        WQ2*WB(IB)*WM(IM)*DM*wpeso(IR)
140                         CONTINUE

160                       CONTINUE
630                     CONTINUE
640                   CONTINUE
		
			

650                CONTINUE
C
                   DO 660 IA=1,NA 
                     EVP(IA,IT)=VECT(IA)*EL0 
660                CONTINUE

670              CONTINUE

C             ******************   TERMINA PROCESO POISSON  ********

               ELSE   

C             ***************  PROCESO CARACTERISTICO  **************

                 EMT=PARSIS(N,1)
             write(*,*) EMT
                 T00=PARSIS(N,2)    
             write(*,*) T00
                 D=  PARSIS(N,3)  
                 F=  PARSIS(N,4)  
                 SMT=PARSIS(N,5)    
                 M0= PARSIS(N,6) 
                 AMU=PARSIS(N,7)  

                 JINC=0 
                 NREF=NR
                 AME=MAX(M0,D+F*LOG(T00))
                 DM=(AMU-M0)/(NM-1)

                 DO 2500 IR=1,NR

                     DO 2450 IT=1,NT

                       DO 2420 IA=1,NA

                         C=A0(IT)+(IA-1)*DA(IT)
                         C=EXP(C)   
                         suma=0.0
                         AMED=CALACA(IMO(N),IT,M0,RR(IR))
	               FG1=FNTRUNC(C,AMED,WAMAX(IMO(N),IT),SLA(IMO(N),IT))
                         FG2=EXP(-0.5*((M0-AME)/SMT)**2)
                         WQ1=FG1*FG2                 
                         AMED=CALACA(IMO(N),IT,AMU,RR(IR))
	               FG1=FNTRUNC(C,AMED,WAMAX(IMO(N),IT),SLA(IMO(N),IT))
                         FG2=EXP(-0.5*((AMU-AME)/SMT)**2)
                         WQ2=FG1*FG2
                         suma=suma+((wq1+wq2)*wpeso(IR))/2

                         DO 2400 IM=2,NM-1
                           MAG=M0+(IM-1)*DM
                           AMED=CALACA(IMO(N),IT,MAG,RR(IR))
 	               FG1=FNTRUNC(C,AMED,WAMAX(IMO(N),IT),SLA(IMO(N),IT))
                          FG2=EXP(-0.5*((MAG-AME)/SMT)**2)
                           WQ1=FG1*FG2
                           suma=suma+wq1*wpeso(IR)
2400                     CONTINUE

                         EVP(IA,IT)=EVP(IA,IT)+suma

2420                   CONTINUE
2450                 CONTINUE
2500             CONTINUE
             
                 AK=FNORAC( (AMU-AME)/SMT )-FNORAC( (M0-AME)/SMT )
                 CEF=DM/(EMT*SQRT(2*3.1416)*SMT*AK)
                 DO 2555 IA=1,NA
                 DO 2555 IT=1,NT
2555             EVP(IA,IT)=EVP(IA,IT)*CEF
 
               ENDIF            
               
               DO 2600 IT=1,NT
                 DO 2550 IA=1,NA
                   ANU(IA,IT)=ANU(IA,IT)+EVP(IA,IT)
2550             CONTINUE
2600           CONTINUE    


c               CALL GETDAT (ANO,MES,DIAdos)  
c
c   seisan date instead of above
c
      call systime(t1,t2)
      read(t1,'(3i2)') ano,mes,diados


	         If(DIAdos.EQ.dia) then
                  TREG=SECS()-TREG
               ELSE
			    DIA=DIAdos
	            TREG=0
	            TSITIO=0
				TREG=SECS()-TREG
			 END IF

               NREFTOT=NREFTOT+NREF
               IF (NREF .GT. 0) WRITE (16,6600) N,NREF,IC(N),JINC,TREG
c	         IF	(NREF.GT.0) WRITE (16,6650 ) NREFTOT

1800        CONTINUE       

C           *******  IMPRESION EN EL ARCHIVO DE RESULTADOS ********
            WRITE(16,6415)
            CALL PRIMA (ANU,NA,NT,A0,DA,T,COEF)

C           *******  IMPRESION EN EL ARCHIVO DE GRAFICAS *************
            NUBAN=0
	      WRITE(7,7900) LOS,LAS
            DO 1500 IT=1,NT
	       WRITE(7,7910) IT
             DO 1400 IA=1,NA
              C=A0(IT)+(IA-1)*DA(IT)
              C=EXP(C)
              WRITE(7,7000)C,ANU(IA,IT) 
C             ESCRIBE TASA DE EXCEDENCIA EN UN ARCHIVO PARA CADA PERIODO ESTRUCTURAL              
              WRITE(26+IT)ANU(IA,IT)
              IF ( ANU(IA,IT) .LE. 0 ) NUBAN=1
1400         CONTINUE
1500        CONTINUE          



C           ****** INTERPOLACION PARA TASAS DE EXCEDENCIA FIJAS:
             DO 1631 IT=1,NT
               DO 1626 I=1,5
	           TE=1.0/TR(I)
                 NBIN(I)=0 
                 IF (ANU(1,IT) .LE. TE) THEN

                    A1=A0(IT)
                    A2=A0(IT)+DA(IT)
				  IF (ANU(1,IT) .LE. 0.0 .OR. ANU(2,IT) .LE. 0.0) THEN	
					VB(I)=0.0
					NBIN(I)=2
				  ELSE
                      ANU1=LOG(ANU(1,IT))
                      ANU2=LOG(ANU(2,IT))
                      EME=(ANU2-ANU1)/(A2-A1)
                      VB(I)=EXP(A1+(LOG(TE)-ANU1)/EME)
                      NBIN(I)=1   
				  ENDIF

                 ELSE IF (ANU(NA,IT) .GT. TE) THEN

                    A1=A0(IT)+(NA-1-1)*DA(IT)
                    A2=A1+DA(IT)
			  IF (ANU(NA,IT) .LE. 0.0 .OR. ANU(NA-1,IT) .LE. 0.0) THEN	
				  	VB(I)=0.0
					NBIN(I)=2
				  ELSE
				    ANU1=LOG(ANU(NA-1,IT))
					ANU2=LOG(ANU(NA,IT))
				    EME=(ANU2-ANU1)/(A2-A1)
				    VB(I)=EXP(A1+(LOG(TE)-ANU1)/EME)
				    NBIN(I)=1
				  ENDIF

                 ELSE
                    
				  DO 1621 K=2,NA

                      IF (ANU(K,IT) .LE. TE) THEN
                        A1=A0(IT)+(K-1-1)*DA(IT)
                        A2=A1+DA(IT)
			  IF (ANU(K,IT) .LE. 0.0 .OR. ANU(K-1,IT) .LE. 0.0) THEN	
		    	    	  VB(I)=0.0
					      NBIN(I)=2
				      ELSE
                            ANU1=LOG(ANU(K-1,IT))
                            ANU2=LOG(ANU(K,IT))
                            EME=(ANU2-ANU1)/(A2-A1)
                            VB(I)=EXP(A1+(LOG(TE)-ANU1)/EME)   
					  ENDIF
                        GOTO 1622
                        
                      ENDIF
1621                CONTINUE      
1622                CONTINUE
                 ENDIF
1626           CONTINUE
               WRITE (9,8120) LOS,LAS,IT,VB(1),VB(2),VB(3),VB(4),VB(5),
     .					    NBIN(1),NBIN(2),NBIN(3),NBIN(4),NBIN(5)         
1631         CONTINUE
         

            TSITIO=(SECS()-TSITIO)/60.0
            WRITE (16,6225) TSITIO
	      TTOTAL=TTOTAL+TSITIO
	      WRITE	(16,6226) TTOTAL


1900      CONTINUE

2000  CONTINUE

      CLOSE (15)
      CLOSE (16)
      CLOSE (7)
      CLOSE (9)   
      
      DO I=1,NT
        CLOSE(26+I)
      ENDDO
 

C	  WHEN BUILDING A DLL, UNCOMMENT FOLLOWING LINES:      
C	  CRISIS=1        
C	  RETURN

C	  WHEN BUILDING A STANDALONE, UNCOMMENT FOLLOWING LINE:
      STOP 'SUCCESFUL TERMINATION'
 
2101  CONTINUE
C	STOP 'FILENAM.NAM DOES NOT EXIST'
C	CRISIS=7
	CALL CIERRA()
C	RETURN 
		
2200	CONTINUE
C	CRISIS=8
	CALL CIERRA()
C	RETURN

1100  FORMAT (' POLIGON IN REGION ',I4,' HAS MORE THAN ',I4,'VERTICES')
1001  FORMAT (3x,'Longitude: ',F8.3,'  Latitude: ',F8.3)
5000  FORMAT (16I5)
5005  FORMAT (I2)
5010  FORMAT (3F9.3) 
5029  FORMAT (6F9.0)
5030  FORMAT (10F9.0)
5031  FORMAT (4F9.0,2I9)
6000  FORMAT(1H1//5X,'PROGRAM CRISIS VERSION ',F5.2//
     1       5X,A80//
     2       5X,'Date : ',I4,'/',I2,'/',I2//)
6001  FORMAT(5X,'VALUES OF PARAMETERS FOR THE PRESENT PROJECT'/
     3          5X,'Number of regions:                    ',I5/
     4       5X,'Number of attenuation models:         ',I5/
     5       5X,'Number of structural periods:         ',I5/
     6       5X,'Number of intensity levels:           ',I5/
     7       5X,'Number of magnitudes for integration: ',I5//
     8       5X,'                INTENSITIES           ',/
     9       5X,' I     T(I)        A0(I)        AU(I)        NA  '
     .         ,'     '/)
6010  FORMAT (4X,I3,1X,3(1PE11.3,1X),5x,I3,2(1PE11.3,1X))
6020  FORMAT(/5X,'Max. dist. of integration:',T50,1PE11.3/) 
6024	FORMAT(/5X,'INITIAL GRID OF POINTS IN WHICH HAZARD WANTS TO BE COM
     1PUTED')
6025  FORMAT(/5X,'Initial site longitude',T50,1PE11.3/
     3        5X,'Initial site latitude',T50,1PE11.3/
     4        5X,'Longitude increment',T50,1PE11.3/
     5        5X,'Latitude increment',T50,1PE11.3/
     6        5X,'No. of points in longitude',T50,I11/
     7        5X,'No. of points in latitude',T50,I11//)
6026  FORMAT(5X,'THE INITIAL GRID WAS MODIFIED WITH THE FOLLOWING POLYGO
     1NS')
6027  FORMAT(/5X,'Number of polygons  ',I2)
6028  FORMAT(5X,'Number of vertex   ',F4.0)
6029  FORMAT(5X,'    LONG            LAT')
6030  FORMAT(5X,F10.3,5X,F10.3)
6035  FORMAT(/5X,'ALFA= Expected value of Alfa',
     1       /5X,'BETA= Expected value of Beta',
     2       /5X,'CBETA=Coefficient of variation of Beta',
     3       /5X,'EMU=  Expected value of the maximum magnitude',
     4       /5X,'SMU=  Standard deviation of the maximum magnitude',
     5       /5X,'MMAX= Maximum observed magnitude',
     6       /5X,'M0=   Treshold magnitude')
6039  FORMAT(/17X,'DEFINITION OF LOCAL POISSONIAN SEISMICITY:')
6040  FORMAT(/,'    REGION   ALFA    BETA   CBETA    EMU',
     .'    SMU       MMAX    MO')
6041  FORMAT (4X,I3,3X,F6.2,3X,F6.2,3X,F5.2,3X,F5.3,3X,F5.3,
     .        3X,F6.2,3X,F4.2,3X,F3.1,3X,F3.1)

6042  FORMAT(/5X,'EMT=  Median value of the time between characteristic 
     .earthquakes (CE)',/5X,'T0=   Time elapsed since the last ocurrence
     .of a CE',/5X,'D=    Parameter defining the expected magnitude',/5
     .X,'F=    Parameter defining the expected magnitude',/5X,'SMT=  Sta
     .ndard deviation of the magnitude of the CE',/5X,'MMIN= Minimum pos   
     .sible magnitude of a CE',/5X,'MU=   Maximum magnitude of the CE')
6044  FORMAT (/16X,'DEFINITION OF LOCAL CHARACTERISTIC SEISMICITY:')
6045  FORMAT (/,'   REGION   EMT      T0        D        F',
     .'      SMT     MMIN    MU')
6046  FORMAT(3X,I3,3X,F6.2,3X,F7.3,3X,F6.2,3X,F6.2,3X,F5.2,3X,F5.2,3X,
     .       F4.2,3X,F3.1,3X,F3.1,3x,F3.1)
6065  FORMAT(//5X,'MAXIMUM MAGNITUDE'/3X,'I',3X,'MU(I)',7X,'P(Mu)')
6066  FORMAT(/'                          PROPERTIES OF THE SOURCES')
6067  FORMAT(/'REGION:',I3,1X,A20)

6070  FORMAT(2X,I3)     
6071  format('        Long     Lat      Depth(km)')     
6072  FORMAT(5X,F7.2,3X,F7.2,3X,F7.2)
     
6074  FORMAT(2X,I2,2X,F6.3,3X,1PE12.4)
6075  FORMAT(//5X,'EPMU= ',F6.3/5X,'SPMU= ',F6.3)
6080  FORMAT(//5X,'BETA'/3X,'I',4X,'B(I)',8X,'P(B)')
6190  FORMAT (3X,'Latitude ',I3,'/',I3,3X,
     .           'Longitude ',I3,'/',I3,3X,
     .           'Region ',I3,'/',I3,3X)
6225  FORMAT (/5X,' Computation time for this site: ',F7.2,' min.')
6226  FORMAT (/5X,' Computation time till this site: ',F7.2,' min.')
6300  FORMAT(//5X,'FOCAL DISTANCE CONCENTRATIONS:'/)
6310  FORMAT(5X,I5,2X,F8.3,2X,F8.3)
6135  FORMAT (/5X,'MAXIMUM VALUES OF PARAMETERS SET IN THE PROGRAM'/
     .         5X,'Attenuation Models :',T50,I3/
     .         5X,'Intensity levels : ',T50,I3/
     .         5X,'Structural periods:',T50,I3/
     .         5X,'Number of regions:',T50,I3/
     .         5X,'Magnitudes in attenuation model:',T50,I3/  
     .         5X,'Distances in attenuation model:',T50,I3/
     .         5X,'Number of subsources per region:',T49,I4/)
6415  FORMAT (//5X,
     *       'INTENSITY versus EXPECTED EXCEEDANCE RATE')
6500  FORMAT (//'****************************************************',
     .          '**************************'/
     .          '****************************************************',
     .          '**************************'//
     .        9X,'Longitude and latitude of the site: ',2(1PE11.3,3X))

6550  FORMAT (/9X,'Number of site:                    ',I6)

6610  FORMAT (/12X,'      SUMMARY OF COMPUTATIONS FOR THIS SITE'//
     . 2X,'Considered   Points used to    Ocurrence    JINC     Time '
     . /2X,'Region       integrate with	   Model'
     . /2x,'             respect to dist.  ' )
6600  FORMAT (3X,I3,14X,I4,9X, I2,12X,I2,3X,F8.2)
6650  FORMAT (/,'Total integration points',I6)
6810  FORMAT (/10X,'                ATTENUATION MODELS      '/
     .'  I       MODEL'   )

6820  FORMAT (1X,I2,3X,A200)
6821  FORMAT (6X,'No. of Mag.',8x,'Lower Mag.',8x,'Magnitude Increment')
6822  FORMAT (6X,'No. of Dist.',7x,'Lower Dist.',7x,'Distance Increment'
     .)
6825  FORMAT (10X,I3,18X,F4.2,15X,F5.3)
6826  FORMAT (10X,I3,18X,F4.2,15X,F8.3)

6830  FORMAT (/13X,'MATRIX OF STANDARD DEVIATIONS OF INTENSITIES'/
     .'  Period -  Model -->')
6840  FORMAT (5X,I2,10(3X,F8.3))
6850  FORMAT (/13X,'MATRIX OF MAXIMUM VALUES OF INTENSITIES'/
     .'  Period  -  Model -->')
6910  FORMAT (///5X,'FINAL RESULTS:'/
     1           5X,'   T         Copt         Pmin           EEER'//)
7000  FORMAT (2(1PE11.3,1X))
7010  FORMAT (1PE11.3,1X)
7500  FORMAT (4X,F6.3,4X,F8.2,4X,2(1PE12.4,4X),' (SEE NOTE 2)')
7510  FORMAT (4X,F6.3,4X,F8.2,4X,2(1PE12.4,4X),' (SEE NOTE 1)')
7520  FORMAT (4X,F6.3,4X,F8.2,4X,2(1PE12.4,4X))
7530  FORMAT (/5X,
     1 'NOTE 1. OPTIMUM NOT FOUND. MINIMUM VALUES ARE GIVEN')
7540  format (5X,
     1 'NOTE 2. OPTIMUM NOT FOUND. MAXIMUM VALUES ARE GIVEN'/)
7900  FORMAT('SITE: ',F8.2,3X,F8.2)
7910  FORMAT('  INTENSITY ',I2)
8120  FORMAT (F8.2,3X,F8.2,3X,I2,5X,F8.2,5X,F8.2,5X,F8.2,5X,F8.2,5X,
     .F8.2,5X,I1,1X,I1,1X,I1,1X,I1,1X,I1)
9000  FORMAT (1X,'[2J','[1m','[12;31H',
     1        'C R I S I S  v ',F3.1,'[0m','[20;60H',
     2        'REGION      ',I2,'/',I2)

9010  FORMAT(2X,'Poisson model')
9015  FORMAT(2X,'Characteristic model')
9020  FORMAT(2X,'Area source')
9025  FORMAT(2X,'Fault source')
9030  FORMAT(2X,'Point source')
9035  FORMAT(2X,'Attenuation model:',2x,A200)
9040  FORMAT(2X,'Number of vertex',I3)
9050  FORMAT(2x,'INTENSITY LEVELS FOR FIXED RETURN PERIODS'
     .)
9060  FORMAT('    Long.       Lat.  NT',5(5X,F8.2),'        NNP'/)
9070  FORMAT('INTENSITY versus EXPECTED EXCEEDANCE RATE')
9090  FORMAT('INOUT ',I2)
9095  FORMAT(5X, F8.2)

      END

C********************************************************************

      SUBROUTINE PRIMA (A,NA,NT,A0,DA,T,CC)
      INTEGER MODMAX,NCMAX,NTMAX,NREGMAX,NMAGMAX,NRMAX,NMCX,NMMAX
      INTEGER NTRIMAX,NVMAX
                          
      PARAMETER (MODMAX=5,NCMAX=20,NTMAX=15,NREGMAX=200,NMAGMAX=10,
     .           NRMAX=21,NMCX=4000,NMMAX=30,NVMAX=25,
     .           NTRIMAX=NREGMAX*NVMAX,NPGMAX=10,NVGMAX=30)     

      DIMENSION A(NCMAX,NTMAX),A0(NT),DA(NT),T(NT),CC(NT)
      NV=1
      NB=0
10    CONTINUE  
      KI=(NV-1)*3+1
      KF=KI+2
      IF (KF .GE. NT) THEN
        KF=NT
        NB=1
      ENDIF
       WRITE(16,5900)
       WRITE(16,6000) (T(K),K=KI,KF)
      DO 100 IA=1,NA
        DO 50 K=KI,KF
          CC(K)=A0(K)+(IA-1)*DA(K)
          CC(K)=EXP(CC(K))
50      CONTINUE  
        WRITE(16,6100) (CC(K),A(IA,K),K=KI,KF)
100   CONTINUE
      NV=NV+1
      IF (NB .EQ. 0) GOTO 10
      RETURN

5900  FORMAT (//)
6000  FORMAT (3(12X,1PE11.3,1X))
6100  FORMAT (6(1PE11.3,1X))


      END

C*********************************************************
      SUBROUTINE ABRIR (UNIT,ARCH)
      INTEGER UNIT
      CHARACTER*200 ARCH
50    CONTINUE                 
      OPEN (UNIT,FILE=ARCH,STATUS='unknown')
      RETURN
100   CONTINUE
      END
C**************************************************************

        FUNCTION DIST (LA1,LO1,LA2,LO2,H)
        REAL LA0,LO0,LAS,LOS
        REAL LA1,LO1,LA2,LO2
        DATA PI/3.141592654/
        LAS=LA1
        LA0=LA2
        LOS=LO1
        LO0=LO2
        IF (ABS(LAS-LA0).LT.1E-3) THEN
           LAS=LAS+1E-4
        ENDIF
        IF (ABS(LOS-LO0).LT.1E-3) THEN
           LOS=LOS+1E-4
        ENDIF
        AA=(90.-LA0)*PI/180.
        BB=(90.-LAS)*PI/180.
        CC=(LOS-LO0)*PI/180.
        B1=ATAN( COS((BB-AA)/2.)/COS((BB+AA)/2.)/TAN(CC/2.) )
        B2=ATAN( SIN((BB-AA)/2.)/SIN((BB+AA)/2.)/TAN(CC/2.) )
        IF (SIN(B2) .EQ. 0) THEN
          WRITE(*,*) LAS,LOS
          WRITE(*,*) LA0,LO0,H
          STOP
        ENDIF
        C1=TAN((BB-AA)/2.)*SIN(B1)/SIN(B2) 
        C1=ATAN(C1)*2.*180./PI
        C1=C1*60*1.852
        DIST=SQRT(C1**2+H**2)
        RETURN
        END

C**********************************************************

      SUBROUTINE CERO (A,N)
      DIMENSION A(N)
      DO 1 I=1,N
1     A(I)=0.0
      RETURN
      END

C***************************************************************

      FUNCTION SECS()
      INTEGER*2 IH,IM,IS,ICS
      CALL GETTIM (IH,IM,IS,ICS)
      SECS=FLOAT(IH)*3600.+FLOAT(IM)*60.+FLOAT(IS)+FLOAT(ICS)/100.
      RETURN
      END

C****************************************************************

      SUBROUTINE LAGUER (NCON,AK,L,R,PROB)
      DIMENSION COEF(30),R(NCON),PROB(NCON),PKN1(30),PK1N1(30)
      REAL L
      CALL COEFI (COEF,NCON,NCON+1,AK,L)
      cnor=coef(ncon+1)/abs(coef(ncon+1))
      do 50 i=1,ncon+1
      coef(i)=coef(i)*cnor
 50   continue
      CALL RAIZ (COEF,NCON,NCON+1,R,AK/L,IER)
      IF(IER .NE. NCON ) THEN
        WRITE(*,*)'***** ERROR EN CALCULO DE B(.) *******'
        WRITE(*,*)'***** IMPOSIBLE CONTINUAR ************'
c        WRITE(1,*)
c     *  '***** ERROR IN COMPUTING CONCENTRATIONS FOR B(.) *******'
        WRITE(*,*)
     *  '***** IMPOSSIBLE TO CONTINUE ************'
        STOP
      ENDIF
      N=NCON-1
      CALL COEFI (COEF,N,N+1,AK,L)
      DO 100 J=1,NCON
         CALL EVALUA ( R(J),PKN1(J),COEF,N,N+1)
 100  CONTINUE
      AK=AK+1
      CALL COEFI(COEF,N,N+1,AK,L)
      DO 200 J=1,NCON
         CALL EVALUA (R(J),PK1N1(J),COEF,N,N+1)
 200  CONTINUE
      SUM=0
      DO 300 J=1,NCON
         PROB(J)=1./(PKN1(J)*PK1N1(J))
         SUM=SUM+PROB(J)
 300  CONTINUE
      DO 400 J=1,NCON
         PROB(J)=PROB(J)/SUM
 400  CONTINUE
      RETURN
      END
C
C**************************************************************
C
      SUBROUTINE COEFI ( COEF,N,N1,AK,L )
C
      DIMENSION COEF(N1)
      REAL L
      GAKN=GAMMA( FLOAT(N)+AK )
      DO 400 M=0,N
         CM=GAKN
         CM=CM-GAMMA( FLOAT(N-M+1) )
         CM=CM+GAMMA( FLOAT(N+1) )
         CM=CM-GAMMA( FLOAT(M)+AK )
         CM=CM-GAMMA( FLOAT(M+1) )
         CM=(-1)**M*EXP(CM)
         COEF(M+1)=CM/L**(N-M)
 400  CONTINUE
      RETURN
      END
C
C*****************************************************************
C
      SUBROUTINE EVALUA (X,Y,COEF,N,N1)
C
C   SUBRUTINA PARA EVALUAR POLINOMIO DE GRADO N
C
      DIMENSION COEF(N1)
      Y=COEF(1)
      DO 100 I=1,N
 100  Y=Y+COEF(I+1)*X**I
      RETURN
      END
C
C********************************************************************
C
      SUBROUTINE RAIZ (A,KN,N1,X,PT,IER)
C
C  SUBRUTINA PARA EL CALCULO DE RAICES DE POLINOMIOS
C  DE GRADO KN. N1=KN+1. LA SUBRUTINA ALTERA LOS COE-
C  FICIENTES DEL POLINOMIO ( ARREGLO A(.) ). LAS RA--
C  ICES REGRESAN EN EL ARREGLO X.
C          SOLO RAICES POSITIVAS
C
C
      DIMENSION A(N1),X(KN)
      DIMENSION D1(20),D2(20),AA(20)
      IER=0
      N=KN
      R1=PT
      K=N
      M=N+1
      DO 200 JJ=1,N-2
         DO 150 I=1,N
            D1(I)=A(I+1)*I
 150     CONTINUE
         DO 170 I=1,N
            D2(I)=D1(I+1)*I
 170     CONTINUE
C
         NIT=0
         NB=0
 175     CONTINUE
         NIT=NIT+1
         S1=0.
         S2=0.
         S3=0.
         DO 180 I=1,N+1
            II=I-1
            S1=S1+A(I)*R1**II
            IF (I .GT. N) GOTO 180
            S2=S2+D1(I)*R1**II
            IF (I .GT. N-1) GOTO 180
            S3=S3+D2(I)*R1**II
 180     CONTINUE
         MM=N-1
         H=(N-1)*((N-1)*S2*S2-N*S1*S3)
         IF( H .LT. 0. ) THEN
            IER=100+IER
            RETURN
         ENDIF
         R2=R1-N*S1/(S2+SQRT(H))
         ER=ABS((R2-R1)/R1)
         IF (ER .LT. 1.E-5 .OR. ABS(S1) .LT. 1.E-3) GOTO 188
         IF (NIT .GT. 200) THEN
            IF(NB .EQ. 1) THEN
               IER=100+IER
               RETURN
            ELSE
               NB=1
               R1=PT
               NIT=0
               GOTO 175
            ENDIF
         ENDIF
         R1=R2
         S1=0.
         S2=0.
         S3=0.
         GOTO 175
 188     CONTINUE
         X(JJ)=R2
         IER=IER+1
         N=N-1
         R1=R2
         NN=N-JJ+1
         M=M-1
         AA(M)=A(M+1)
         DO 190 I=1,M-1
            AA(M-I)=AA(M+1-I)*R2+A(M+1-I)
 190     CONTINUE
         DO 195 I=1,M
            A(I)=AA(I)
 195     CONTINUE
 200  CONTINUE
C
      D=A(2)*A(2)-4.*A(3)*A(1)
      IF( D .LT. 0. ) THEN
        IER=98
        RETURN
      ENDIF
      D=SQRT(D)
      MM=K-1
      X(MM)=(D-A(2))/2./A(3)
      X(K)=(-D-A(2))/2./A(3)
      IER=IER+2
      RETURN
      END
C
C***************************************************************
C
      FUNCTION GAMMA (X)
C
C   CALCULO DEL LOGARITMO NATURAL DE LA FUNCION GAMMA
C         X>=0
C
      DATA A,B,C,D,E/.918938534,12.,360.,1260.,1680./
      XM1=X+1
      GAMMA=(XM1-.5)*ALOG(XM1)-XM1+A
      GAMMA=GAMMA+1./(B*XM1)-1./(C*XM1**3.)
      GAMMA=GAMMA+1./(D*XM1**5.)-1./(E*XM1**7.)
      GAMMA=GAMMA-ALOG(X)
      RETURN
      END
C
c****+*****************************************************************
C
      FUNCTION CALACA (IMO,NT,MAG,RR)
      IMPLICIT NONE
C
      INTEGER MODMAX,NCMAX,NTMAX,NREGMAX,NMAGMAX,NRMAX,NMCX,NMMAX
      INTEGER NVMAX,NTRIMAX,NPGMAX,NVGMAX
       
      PARAMETER (MODMAX=5,NCMAX=20,NTMAX=15,NREGMAX=200,NMAGMAX=10,
     .           NRMAX=21,NMCX=4000,NMMAX=30,NVMAX=25,
     .           NTRIMAX=NREGMAX*NVMAX,NPGMAX=10,NVGMAX=30)     
       
c
      REAL MAG,MINF,R,ACEL,SLA,DMAG,RINF,DRAD,WAMAX
      REAL M1,r1,u,t,calaca,cl,RR
      INTEGER IMO,NT,NMAG,NRAD,NM,NR
C
      COMMON/ATENUA/ACEL(MODMAX,NTMAX,NMAGMAX,NRMAX),SLA(MODMAX,NTMAX),
     1              MINF(MODMAX),DMAG(MODMAX),RINF(MODMAX),DRAD(MODMAX),
     2              NMAG(MODMAX),NRAD(MODMAX),WAMAX(MODMAX,NTMAX)
C     
      R=ALOG(RR)
      NM=INT( (MAG-MINF(IMO))/DMAG(IMO))+1
      NR=INT( (R-RINF(IMO))/DRAD(IMO))+1
C
      IF (NM .LT. 1) NM=1
      IF (NR .LT. 1)  NR=1
      IF (NM .GT. NMAG(IMO)-1) NM=NMAG(IMO)-1
      IF (NR .GT. NRAD(IMO)-1) NR=NRAD(IMO)-1
c
      M1=MINF(IMO)+(NM-1)*DMAG(IMO)
      R1=RINF(IMO)+(NR-1)*DRAD(IMO) 
      T=(MAG-M1)/DMAG(IMO)
      U=(R  -R1)/DRAD(IMO)
      CL=(1-T)*(1-U)*ALOG(ACEL(IMO,NT,NM  ,NR  ))+
     .     T  *(1-U)*ALOG(ACEL(IMO,NT,NM+1,NR  ))+
     .     T  *  U  *ALOG(ACEL(IMO,NT,NM+1,NR+1))+
     .   (1-T)*  U  *ALOG(ACEL(IMO,NT,NM  ,NR+1))

      CALACA=EXP(CL)
      RETURN
      END      
        
c
C
C***********************************************************************
C       SUBROUTINE TO EVALUATE THE GAUSSIAN PROBABILITY DISTRIBUTION      
C       TAKEN FROM ABRAMOWITZ AND STEGUN, HANDBOOK OF MATHEMATICAL
C       FUNCTIONS, PAGE 932.(NOVEMBER, 1991)
C
        FUNCTION FNORAC (ARG)
        IMPLICIT NONE
        REAL B(5),ARG,FNORAC,T,TT,S
        INTEGER I
C
        DATA B/0.319381530,-0.356563782,1.781477937,
     1        -1.821255978, 1.330274429/
C
        T=1./(1.+0.2316419*ABS(ARG))
        TT=T
        S=0.0
        DO 100 I=1,5
            S=S+TT*B(I)
            TT=TT*T
100     CONTINUE
        S=0.3989423*EXP(-0.5*ARG*ARG)*S
        IF (ARG .GE. 0.0) THEN
          FNORAC=1.0-S
        ELSE
            FNORAC=S
        ENDIF
        RETURN
        END                           
C
C***************************************************************
C
      FUNCTION PM(MAG,M0,B,MU)
      IMPLICIT NONE
      REAL MAG,M0,MU,B,PM
      IF (MAG .GE. M0 .AND. MAG .LT. MU) THEN
        PM=B*EXP(-B*MAG)/( EXP(-B*M0) - EXP (-B*MU) )
      ELSE
        PM=0.0
      ENDIF
      RETURN
      END
CC
C     FUNCTION RADIO (AMAG,R,H)
c     RBAS=SQRT(R*R-H*H)
c     REQ=SQRT(10.0**(AMAG-4)/3.1416)
c     R1=RBAS-REQ
c     IF (R1 .LT. 0.0) R1=0.0
c     RADIO=SQRT(R1*R1+H*H)
C     RADIO=R
C     RETURN
C     END
C                     

c========================================================== 

      subroutine triangulate(np,nstot,ns,xys,ntri,xytri)

      PARAMETER (MODMAX=5,NCMAX=20,NTMAX=15,NREGMAX=200,NMAGMAX=10,
     .           NRMAX=21,NMCX=4000,NMMAX=30,NVMAX=25,
     .           NTRIMAX=NREGMAX*NVMAX,NPGMAX=10,NVGMAX=30)     

      dimension ns(1:np),xys(1:3,1:nstot),xytri(1:3,1:3,1:ntri)
      DIMENSION XYTMP (1:3,1:NTRIMAX)
      dimension ixy(500),ixy3(3,500)
      INTEGER SEPUEDE
      INTEGER NUM
      data idebug / 0 /             ! 1 for debug output

	DO I=1,3
		SEPUEDE=PLANO(I,NS(1),XYS,XYTMP)	
		IF (SEPUEDE .NE. 0) THEN
			NUM=NUMERA(NS(1),XYTMP)
			IF (NUM .NE. 0) THEN
				GOTO 100
			ELSE
				NTRI=0
				RETURN
			ENDIF
		ENDIF
	ENDDO
	NTRI=0
	RETURN

100	CONTINUE

	k=0
      ntri=0
      do 10 i=1,np
        nsi=ns(i)
        do 15 j=1,nsi
          k=k+1
          ixy(j)=k
15      continue
        call deldivide (nsi,ixy,XYTMP,m,ixy3,idebug)
        do 20 j=1,m
          ntri=ntri+1
          itri1=ixy3(1,j)
          itri2=ixy3(2,j)
          itri3=ixy3(3,j)
          xytri(1,1,ntri)=xys(1,itri1)
          xytri(1,2,ntri)=xys(1,itri2)
          xytri(1,3,ntri)=xys(1,itri3)
          xytri(2,1,ntri)=xys(2,itri1)
          xytri(2,2,ntri)=xys(2,itri2)
          xytri(2,3,ntri)=xys(2,itri3)
C         MODIFICACION PARA INCLUIR Z
          xytri(3,1,ntri)=xys(3,itri1)
          xytri(3,2,ntri)=xys(3,itri2)
          xytri(3,3,ntri)=xys(3,itri3)
20      continue
10    continue

      return
      end

c==========================================================
      subroutine deldivide (n,ixy,xy,m,ixy3,idebug)
      dimension ixy(n),xy(3,n),ixy3(3,m)

      m=0
      do 10 i=n,3,-1
      ii = i
      m=m+1
      call delsplit (ii,ixy,xy,ixy3(1,m),idebug)
10    continue
      return
      end

c==========================================================
      subroutine delsplit (n,ixy,xy,ixy3,idebug)
      dimension ixy(n),ixy3(3),xy(3,n)

      if (n.eq.3) then
            ixy3(1) = ixy(1)
            ixy3(2) = ixy(2)
            ixy3(3) = ixy(3)
            ixy(1) = 0
            ixy(2) = 0
            ixy(3) = 0
            n = 0
      else if (n.gt.3) then
            do 10 j2=1,n
                  j1 = j2-1
                  if (j1.le.0) j1=j1+n
                  j3 = j2+1
                  if (j3.gt.n) j3=j3-n
                  ixyj1=ixy(j1)
                  ixyj2=ixy(j2)
                  ixyj3=ixy(j3)
                  call delaunay(n,ixy,xy,ixyj1,ixyj2,ixyj3,
     .                  idel,idebug)
                  if (idel.eq.1.or.idel.eq.2) then
                        ielim1=ixy(j1)
                        ielim2=ixy(j2)
                        ielim3=ixy(j3)
                        ixy3(1) = ixy(j1)
                        ixy3(2) = ixy(j2)
                        ixy3(3) = ixy(j3)
                        do 20 j=j2,n-1
                              ixy(j)=ixy(j+1)   
20                      continue
                        ixy(n)=0
                        n=n-1
                        go to 11
                  endif
10          continue
11    continue
      endif
      return
      end

c==========================================================
      SUBROUTINE DELAUNAY(n,ixy,xy,j1,j2,j3,IDEL,idebug)
      dimension ixy(1),xy(3,1)
      
      xj1=xy(1,j1)
      xj2=xy(1,j2)
      xj3=xy(1,j3)
      yj1=xy(2,j1)
      yj2=xy(2,j2)
      yj3=xy(2,j3)

      dx23=xj3-xj2
      dx31=xj1-xj3
      dx12=xj2-xj1
      sx23=xj3+xj2
      sx31=xj1+xj3
      sx12=xj2+xj1

      dy23=yj3-yj2
      dy31=yj1-yj3
      dy12=yj2-yj1
      sy23=yj3+yj2
      sy31=yj1+yj3
      sy12=yj2+yj1

      term1=(dx23*sy23)-(dy23*sx23)
      term2=(dx31*sy31)-(dy31*sx31)
      term3=(dx12*sy12)-(dy12*sx12)

      area=-0.25*(term1+term2+term3)

         if (area.lt.0) idel=5
         if (area.eq.0) idel=4
         if (area.gt.0) idel=3

      CALL CIRCUM(xj1,yj1,xj2,yj2,xj3,yj3,X0,Y0,RSQ)
         if (idel.gt.3) return
      if (idebug.eq.1) then
            if (rsq.ge.0.) then
                  rr=sqrt(rsq)
            else
                  rr=-999.
            endif
      endif
      if (rsq.eq.-999) goto 30

      do 10 k=1,n
      kj=ixy(k)
      if (xy(1,kj).eq.xy(1,j1).and.xy(2,kj).eq.xy(2,j1)) goto 10
      if (xy(1,kj).eq.xy(1,j2).and.xy(2,kj).eq.xy(2,j2)) goto 10
      if (xy(1,kj).eq.xy(1,j3).and.xy(2,kj).eq.xy(2,j3)) goto 10
      dx=xy(1,kj)-x0
      dy=xy(2,kj)-y0
      r2=(dx*dx)+(dy*dy)

         if (r2.lt.rsq) goto 30
         if (r2.eq.rsq) then
            idel=2
         endif
   10 continue
      idel=1
      return
   30 idel=3
      return
      end

c==========================================================
      SUBROUTINE CIRCUM(x1,y1,x2,y2,x3,y3,X0,Y0,RSQ)

       x0 = -999.0
       y0 = -999.0
      rsq = -999.0
      sx13=0.5*(x1+x3)
      sy13=0.5*(y1+y3)
      dx13=(x3-x1)
      dy13=(y3-y1)
      sx12=0.5*(x1+x2)
      sy12=0.5*(y1+y2)
      dx12=(x2-x1)
      dy12=(y2-y1)
      den = (dx13*dy12) - (dx12*dy13)

      if (den.eq.0) return
      xfac1 =  (sy13*dy13) + (sx13*dx13) 
      xfac2 =  (sy12*dy12) + (sx12*dx12) 
      yfac1 =  (sx13*dx13) + (sy13*dy13)
      yfac2 =  (sx12*dx12) + (sy12*dy12)
      xnum  =  (xfac1*dy12) - (xfac2*dy13)
      ynum  =  (yfac1*dx12) - (yfac2*dx13)
      x0    =  xnum/den
      y0    =  -ynum/den
      dx10  =  x1-x0
      dx20  =  x2-x0
      dx30  =  x3-x0
      dy10  =  y1-y0
      dy20  =  y2-y0
      dy30  =  y3-y0
      rsq1  =  (dx10*dx10)+(dy10*dy10)
      rsq2  =  (dx20*dx20)+(dy20*dy20)
      rsq3  =  (dx30*dx30)+(dy30*dy30)
      rsq = rsq1
      return
      end

c==================================================
C******************************************************************
      Function areatr(uno,dos,tres)
      real uno,dos,tres,a,beta,b,c,m
      real areatr,x1,x2,x3,y1,y2,y3,PI
      data PI/3.141592654/
      
      a=min(uno,dos,tres)
      c=max(uno,dos,tres)

      if(a.eq.uno.and.c.eq.dos)then
      b=tres
      else
      if(a.eq.uno.and.c.eq.tres)then
      b=dos                         
      else
      if(a.eq.dos.and.c.eq.uno)then
      b=tres
      else
      if(a.eq.dos.and.c.eq.tres)then
      b=uno
      else
      if(a.eq.tres.and.c.eq.uno)then
      b=dos
      else
      b=uno
      endif
      endif
      endif
      endif
      endif            
      
      m=(a**2+c**2-b**2)/(2*a*c)      

      Beta=Acos(m)
      x1=0.0
      y1=a
      x2=c*cos((90.0*PI/180)-beta)
      y2=(c*sin((90.0*PI/180)-beta))-a
      x3=x2
      y3=(c*sin((90.0*PI/180)-beta))

      areatr=0.5*((x2-x1)*(y3-y1)-(x3-x1)*(y2-y1))
      
      return
      
      end

C================================================================
      FUNCTION AREA3D (X1,Y1,Z1,X2,Y2,Z2,X3,Y3,Z3)
C     FUNCION QUE EVALUA EL AREA DE UN TRIANGULO EN EL ESPACIO

      REAL X1,Y1,Z1,X2,Y2,Z2,X3,Y3,Z3

      XX2=DIST(Y1,X1,Y1,X2,0.)*SGN(X2-X1)
      YY2=DIST(Y1,X1,Y2,X1,0.)*SGN(Y2-Y1)

      XX3=DIST(Y1,X1,Y1,X3,0.)*SGN(X3-X1)
      YY3=DIST(Y1,X1,Y3,X1,0.)*SGN(Y3-Y1)
      ZZ2=Z2-Z1
      ZZ3=Z3-Z1
      FI=(YY2*ZZ3-YY3*ZZ2)**2+(XX3*ZZ2-XX2*ZZ3)**2+(XX2*YY3-XX3*YY2)**2
      AREA3D=0.5*SQRT(FI)
      RETURN
      END
C================================================================


      SUBROUTINE DIVREC(X1,Y1,Z1,X2,Y2,Z2,X3,Y3,Z3)
c
c     ************************************************************
c     Subrutina recursiva (indirecta) de subdivision en triangulos
c     ************************************************************
c
      PARAMETER (MODMAX=5,NCMAX=20,NTMAX=15,NREGMAX=200,NMAGMAX=10,
     .           NRMAX=21,NMCX=4000,NMMAX=30,NVMAX=25,
     .           NTRIMAX=NREGMAX*NVMAX,NPGMAX=10,NVGMAX=30)     


      COMMON/TRIAN/KTR,RR(NMCX),WPESO(NMCX),XSITE,YSITE,HSITE,RMAX,
     *             RMIN,FMIN

      AUTOMATIC U1,U2,U3,U4,U5,U6
      AUTOMATIC V1,V2,V3,V4,V5,V6
      AUTOMATIC W1,W2,W3,W4,W5,W6

      X22=X2-X1
      X33=X3-X1
      Y22=Y2-Y1
      Y33=Y3-Y1
      Z22=Z2-Z1
      Z33=Z3-Z1

C     ---- Calcula coord. del centroide
      XC=X1+(X22+X33)/3.
      YC=Y1+(Y22+Y33)/3.
      ZC=Z1+(Z22+Z33)/3.
C
      DISTA=DIST(YC,XC,YSITE,XSITE,ZC)   
      TAM=SQRT(AREA3D(X1,Y1,Z1,X2,Y2,Z2,X3,Y3,Z3))
      FACTOR = DISTA/TAM   
 

C     SI FACTOR.GT.FMIN SIGNIFICA QUE LA FUENTE ESTA MUY LEJANA O ES MUY 
C     PEQUE¥A Y NO REQUIERE SUBDIVIDIRSE
C     SI TAM. LT. RMIN LA FUENTE ES YA MUY PEQUE¥A Y NO REQUIERE SUBD

      IF (FACTOR.GT.FMIN .OR. TAM .LT. RMIN) THEN

         IF (DISTA .LT. RMAX) THEN
           KTR = KTR + 1
           IF (KTR .GT. NMCX) THEN 
             WRITE(16,*) 'DEMASIADAS CELDAS EN LA REGION'
             CLOSE(15)
             CLOSE(16)
             STOP 'ERROR CRITICO. DEMASIADAS CELDAS EN LA REGION'
           ENDIF
           RR(KTR)=DISTA
           WPESO(KTR)= TAM*TAM

c          ---- Escritura temporal para pruebas ----------------- 
C          write (21,2100) KTR,XC,YC,WPESO(KTR)
C          write (22,*) 'READ 4'
C          write (22,2200)x1,y1
C          write (22,2200)x2,y2
C          write (22,2200)x3,y3
C          write (22,2200)x1,y1
C          IF (MOD(KTR,20) .EQ. 0) WRITE(22,'(A)') 'PLOT 0 0'
C2100       format(i5,3f10.4)
C2200       format(2f10.4)
c          -------------------------------------------------------
           RETURN

C        SI LA FUENTE ESTA A UNA DISTANCIA MATOR A RMAX NO SE CONSIDERARA
         ELSE
           RETURN
         END IF

      END IF
 
c     ----  Calcula v‚rtices de nuevos tri ngulos ---------
      U1=X1
      U2=X1+X22/2.0
      U3=X1+X33/2.0
      U4=X2
      U5=X1+(X33+X22)/2.0
      U6=X3
      V1=Y1
      V2=Y1+Y22/2.0
      V3=Y1+Y33/2.0
      V4=Y2
      V5=Y1+(Y33+Y22)/2.0           
      V6=Y3

      W1=Z1
      W2=Z1+Z22/2.0 
      W3=Z1+Z33/2.0
      W4=Z2
      W5=Z1+(Z22+Z33)/2.0
      W6=Z3

c     ---- Subdivide los cuatro tri ngulos
      CALL DAVREC(U1,V1,W1,U2,V2,W2,U3,V3,W3)
      CALL DAVREC(U2,V2,W2,U4,V4,W4,U5,V5,W5)
      CALL DAVREC(U2,V2,W2,U5,V5,W5,U3,V3,W3)
      CALL DAVREC(U3,V3,W3,U5,V5,W5,U6,V6,W6)
       
      RETURN
      END

c*****************************************************************************
c
      SUBROUTINE DAVREC (U1,V1,W1,U2,V2,W2,U3,V3,W3)
c     **** Subrutina para simular la recur- **** 
c     **** sividad directa.                 ****
      AUTOMATIC A1,A2,A3,B1,B2,B3
      A1=U1
      A2=U2
      A3=U3
      B1=V1
      B2=V2
      B3=V3
      C1=W1
      C2=W2
      C3=W3
      CALL DIVREC (A1,B1,C1,A2,B2,C2,A3,B3,C3)
      RETURN      
      END

C     ***************************************************************
      SUBROUTINE DIVLIN(X1,Y1,Z1,X2,Y2,Z2)
c
c     ************************************************************
c     Subrutina recursiva (indirecta) de subdivision en lineas
c     ************************************************************
c
      PARAMETER (MODMAX=5,NCMAX=20,NTMAX=15,NREGMAX=200,NMAGMAX=10,
     .           NRMAX=21,NMCX=4000,NMMAX=30,NVMAX=25,
     .           NTRIMAX=NREGMAX*NVMAX,NPGMAX=10,NVGMAX=30)     

      
      COMMON/TRIAN/KTR,RR(NMCX),WPESO(NMCX),XSITE,YSITE,HSITE,RMAX,
     *             RMIN,FMIN

      AUTOMATIC U1,U2,U3
      AUTOMATIC V1,V2,V3
      AUTOMATIC W1,W2,W3 

      FMIN=10
      
      X22=X2-X1
      Y22=Y2-Y1
      Z22=Z2-Z1

C     ---- Calcula coord. del centroide
      XC=X1+X22/2.0
      YC=Y1+Y22/2.0       
      ZC=Z1+Z22/2.0
      DISTA=DIST(YC,XC,YSITE,XSITE,ZC)
      TAM=DIST(Y1,X1,Y2,X2,ABS(Z22))
      FACTOR = DISTA/TAM

      IF (FACTOR.GT.FMIN .OR. TAM .LT. RMIN) THEN  

         IF (DISTA .LT. RMAX) THEN
           KTR = KTR + 1
           RR(KTR)=DISTA
           WPESO(KTR)= TAM           
c          ---- Escritura temporal para pruebas ----------------- 
C          write (21,2100) KTR,XC,YC,WPESO(KTR)
C          write (22,*) 'READ 2'
C          write (22,2200)x1,y1
C          write (22,2200)x2,y2
C          IF (MOD(KTR,20) .EQ. 0) WRITE(22,'(A)') 'PLOT 0 0'
C2100       format(i5,3f10.4)
C2200       format(2f10.4)
c          -------------------------------------------------------
           RETURN
         ELSE
           RETURN
         END IF

      END IF   
      U1=X1
      U2=X2
      U3=XC
      V1=Y1
      V2=Y2
      V3=YC
      W1=Z1
      W2=Z2
      W3=ZC
 
c     ---- Subdivide las dos lineas
      CALL DAVLIN(U1,V1,W1,U3,V3,W3)
      CALL DAVLIN(U3,V3,W3,U2,V2,W2)
       
      RETURN
      END
c*****************************************************************************
c
      SUBROUTINE DAVLIN (U1,V1,W1,U2,V2,W2)
c     **** Subrutina para simular la recur- **** 
c     **** sividad directa.                 ****
      AUTOMATIC A1,A2,B1,B2,C1,C2
      A1=U1   
      B1=V1
      C1=W1
      A2=U2
      B2=V2
      C2=W2
      CALL DIVLIN (A1,B1,C1,A2,B2,C2)
      RETURN      
      END

c *************************************************************************
C
      FUNCTION SGN(X)
      IF (X .EQ. 0) THEN
         SGN=0.0
      ELSE
         SGN=X/ABS(X)
      ENDIF
      RETURN
      END

C **********************************************************************
      SUBROUTINE POLINS(NVERG,VCLGRID,PT,INOUT)
	IMPLICIT LOGICAL (A-Z)
cC
cC     Driver program for testing routines PTPOLG.
cC     Routines called:
cC        INITCB, PTPOLG
cC
      DOUBLE PRECISION PI,TOL
      COMMON /GCONST/ PI,TOL
cC
      INTEGER MAXN
      PARAMETER (MAXN = 30)
C
      INTEGER I,INOUT,IPRT,IRDR,PGIND(0:MAXN),NVERG
      DOUBLE PRECISION DTOL,NRML(3),PT(2),VCLGRID(2,MAXN)
C
	I=0
      IRDR = 5
      IPRT = 6
C      CALL INITCB(0.0D0)
C      DTOL = 10.0D0*TOL
C     LECTURA DEL NUMERO DE VERTICES DEL POLIGONO
cc      READ (IRDR,*) NVERG
      IF (NVERG .LT. 3) STOP
      IF (NVERG .GT. MAXN) THEN
c	  WRITE (IPRT,600) 'MAXN',NVERG
	  STOP
      ENDIF
C LECTURA DE COORDENADAS DE CADA VERTICE
cc      READ (IRDR,*) (VCLGRID(1,I),VCLGRID(2,I),I=1,NVERG)
      PGIND(0) = NVERG
      DO 10 I = 1,NVERG
	  PGIND(I) = I
C	  WRITE (IPRT,620) I,(VCL(J,I),J=1,DIM)
c	  WRITE (16,620) I,(VCLgrid(j,I),j=1,2)
c	    write(16,*) vclgrid(1,I)
c		write(16,*) VCLGRID(2,I)
   10 CONTINUE
c      WRITE (IPRT,620)
C   20 CONTINUE
C	LECTURA DEL PUNTO A EVALUAR
cc	  READ (IRDR,*,END=30) PT(1),PT(2)
	  CALL PTPOLG(2,2,NVERG,1,PGIND,VCLGRID,PT,NRML,DTOL,INOUT)
c        WRITE (IPRT,630) INOUT,(PT(I),I=1,2)
	 RETURN
C      GO TO 20
   30 CONTINUE
C
  600 FORMAT (1X,'*** ',A,' must be increased to',I8)
  610 FORMAT (1X,'DIM=',I2,3X,'A,B=',2F15.7)
  620 FORMAT (1X,I5,3F15.7)
  630 FORMAT (1X,'INOUT=',I3,3X,'PT=',3F15.7)
      END
     	    
      SUBROUTINE PTPOLG(DIM,LDV,NVERG,INC,PGIND,VCLGRID,PT,NRML,DTOL,
     .                  INOUT)
      IMPLICIT LOGICAL (A-Z)
      INTEGER DIM,INC,INOUT,LDV,NVERG,PGIND(0:*)
      DOUBLE PRECISION DTOL,NRML(3),PT(DIM),VCLGRID(LDV,*)
C
C     Purpose: Determine whether a point lies inside, outside, or on
C        boundary of a planar polygon in 2 or 3 dimensional space.
C        It is assumed that point lies in plane of polygon.
C
C     Input parameters:
C        DIM - dimension of polygon (2 or 3)
C        LDV - leading dimension of VCL array in calling routine
C        NV - number of vertices in polygon
C        INC - increment for PGIND indicating indices of polygon
C        PGIND(0:NV*INC) - indices in VCL of polygon vertices are in
C              PGIND(0), PGIND(INC), ..., PGIND(NV*INC) with first and
C              last vertices identical
C        VCL(1:DIM,1:*) - vertex coordinate list
C        PT(1:DIM) - point for which in/out test is applied
C        NRML(1:3) - unit normal vector of plane containing polygon,
C              with vertices oriented CCW wrt normal (used iff DIM = 3);
C              normal is assumed to be (0,0,1) if DIM = 2
C        DTOL - absolute tolerance to determine whether a point is on
C              a line or plane
C
C     Output parameters:
C        INOUT - +1, 0, or -1 depending on whether point PT is inside
C              polygon, on boundary of polygon, or outside polygon;
C              or -2 if error in input parameters
C
      DOUBLE PRECISION PI,TOL
      COMMON /GCONST/ PI,TOL
      SAVE /GCONST/
C
      DOUBLE PRECISION CP(3),DIR(3),DE(3),NR(4),RHS(3)
      DOUBLE PRECISION DIST,DOTP,LEN1,LEN2,T,TA
      INTEGER I,J,K,L,LA,LB,M,N,S,SA,SB
C
c	do I=1,nverg
c	   write(16,*) '2',vclgrid(1,I)
c	   write(16,*)'2', VCLGRID(2,I)
c	end do

      INOUT = -2
      IF (DIM .LT. 2 .OR. DIM .GT. 3) RETURN
C
C     Direction of ray is from PT through midpoint of first edge
C     such that PT is not collinear with edge. NR is normal of plane
C     containing ray, which is also orthogonal to NRML.
C
      I = 0
      LB = PGIND(0)
   10 CONTINUE
	 I = I + 1
	 IF (I .GE. NVERG) RETURN
         LA = LB
         LB = PGIND(I*INC)
	 DO 20 J = 1,DIM
	    DE(J) = VCLGRID(J,LB) - VCLGRID(J,LA)
	    DIR(J) = PT(J) - VCLGRID(J,LA)
   20    CONTINUE
	 IF (DIM .EQ. 2) THEN
	    LEN1 = DE(1)**2 + DE(2)**2
	    LEN2 = DIR(1)**2 + DIR(2)**2
	 ELSE
	    LEN1 = DE(1)**2 + DE(2)**2 + DE(3)**2
	    LEN2 = DIR(1)**2 + DIR(2)**2 + DIR(3)**2
	 ENDIF
	 IF (LEN1 .EQ. 0.0D0) THEN
	    GO TO 10
	 ELSE IF (LEN2 .EQ. 0.0D0) THEN
	    INOUT = 0
	    RETURN
	 ENDIF
	 IF (DIM .EQ. 2) THEN
	    DOTP = ABS(DE(1)*DIR(1) + DE(2)*DIR(2))/SQRT(LEN1*LEN2)
	 ELSE
	    DOTP = ABS(DE(1)*DIR(1) + DE(2)*DIR(2) + DE(3)*DIR(3))/
     $         SQRT(LEN1*LEN2)
	 ENDIF
      IF (DOTP .GE. 1.0D0 - TOL) GO TO 10
C
      IF (DIM .EQ. 2) THEN
         DIR(1) = 0.5D0*(VCLGRID(1,LA) + VCLGRID(1,LB)) - PT(1)
         DIR(2) = 0.5D0*(VCLGRID(2,LA) + VCLGRID(2,LB)) - PT(2)
         DIST = SQRT(DIR(1)**2 + DIR(2)**2)
         DIR(1) = DIR(1)/DIST
         DIR(2) = DIR(2)/DIST
	 DIR(3) = 0.0D0
         NR(1) = -DIR(2)
         NR(2) = DIR(1)
         NR(3) = 0.0D0
         NR(4) = NR(1)*PT(1) + NR(2)*PT(2)
         DIST = NR(1)*VCLGRID(1,LB) + NR(2)*VCLGRID(2,LB) - NR(4)
      ELSE
         DIR(1) = 0.5D0*(VCLGRID(1,LA) + VCLGRID(1,LB)) - PT(1)
         DIR(2) = 0.5D0*(VCLGRID(2,LA) + VCLGRID(2,LB)) - PT(2)
         DIR(3) = 0.5D0*(VCLGRID(3,LA) + VCLGRID(3,LB)) - PT(3)
         DIST = SQRT(DIR(1)**2 + DIR(2)**2 + DIR(3)**2)
         DIR(1) = DIR(1)/DIST
         DIR(2) = DIR(2)/DIST
         DIR(3) = DIR(3)/DIST
         NR(1) = NRML(2)*DIR(3) - NRML(3)*DIR(2)
         NR(2) = NRML(3)*DIR(1) - NRML(1)*DIR(3)
         NR(3) = NRML(1)*DIR(2) - NRML(2)*DIR(1)
         NR(4) = NR(1)*PT(1) + NR(2)*PT(2) + NR(3)*PT(3)
         DIST = NR(1)*VCLGRID(1,LB)+NR(2)*VCLGRID(2,LB)+NR(3)*VCLGRID
     .   (3,LB) - NR(4)
      ENDIF
      IF (DIST .GT. 0.0D0) THEN
	 SB = 1
      ELSE
	 SB = -1
      ENDIF
      M = 1
      IF (ABS(DIR(2)) .GT. ABS(DIR(1))) M = 2
      IF (ABS(DIR(3)) .GT. ABS(DIR(M))) M = 3
      K = 1
C
C     For remaining edges of polygon, check whether ray intersects edge.
C     Vertices or edges lying on ray are handled by looking at preceding
C     and succeeding edges not lying on ray.
C
      N = I
      I = I + 1
   30 CONTINUE
	 LA = LB
	 LB = PGIND(I*INC)
	 SA = SB
	 IF (DIM .EQ. 2) THEN
            DIST = NR(1)*VCLGRID(1,LB) + NR(2)*VCLGRID(2,LB) - NR(4)
	 ELSE
            DIST = NR(1)*VCLGRID(1,LB) + NR(2)*VCLGRID(2,LB) + NR(3)
     .	  *VCLGRID(3,LB)
     $         - NR(4)
	 ENDIF
	 IF (ABS(DIST) .LE. DTOL) THEN
	    SB = 0
         ELSE IF (DIST .GT. 0.0D0) THEN
	    SB = 1
         ELSE
	    SB = -1
         ENDIF
	 S = SA*SB
	 IF (S .LT. 0) THEN
	    IF (DIM .EQ. 2) THEN
	       DE(1) = VCLGRID(1,LA) - VCLGRID(1,LB)
	       DE(2) = VCLGRID(2,LA) - VCLGRID(2,LB)
	       RHS(1) = VCLGRID(1,LA) - PT(1)
	       RHS(2) = VCLGRID(2,LA) - PT(2)
	       T = (RHS(1)*DE(2) - RHS(2)*DE(1))/(DIR(1)*DE(2) -
     $            DIR(2)*DE(1))
	    ELSE
	       DE(1) = VCLGRID(1,LA) - VCLGRID(1,LB)
	       DE(2) = VCLGRID(2,LA) - VCLGRID(2,LB)
	       DE(3) = VCLGRID(3,LA) - VCLGRID(3,LB)
	       RHS(1) = VCLGRID(1,LA) - PT(1)
	       RHS(2) = VCLGRID(2,LA) - PT(2)
	       RHS(3) = VCLGRID(3,LA) - PT(3)
	       CP(1) = DIR(2)*DE(3) - DIR(3)*DE(2)
	       CP(2) = DIR(3)*DE(1) - DIR(1)*DE(3)
	       CP(3) = DIR(1)*DE(2) - DIR(2)*DE(1)
	       L = 1
	       IF (ABS(CP(2)) .GT. ABS(CP(1))) L = 2
	       IF (ABS(CP(3)) .GT. ABS(CP(L))) L = 3
	       IF (L .EQ. 1) THEN
	          T = (RHS(2)*DE(3) - RHS(3)*DE(2))/CP(1)
	       ELSE IF (L .EQ. 2) THEN
	          T = (RHS(3)*DE(1) - RHS(1)*DE(3))/CP(2)
	       ELSE
	          T = (RHS(1)*DE(2) - RHS(2)*DE(1))/CP(3)
	       ENDIF
	    ENDIF
	    IF (T .GT. DTOL) THEN
	       K = K + 1
	    ELSE IF (T .GE. -DTOL) THEN
	       INOUT = 0
	       RETURN
	    ENDIF
	 ELSE IF (S .EQ. 0) THEN
	    L = LB
   40       CONTINUE
	    I = I + 1
	    IF (I .GT. NVERG) I = 1
	    IF (I .EQ. N) RETURN
	    LA = LB
	    LB = PGIND(I*INC)
	    IF (DIM .EQ. 2) THEN
               DIST = NR(1)*VCLGRID(1,LB) + NR(2)*VCLGRID(2,LB) - NR(4)
	    ELSE
               DIST = NR(1)*VCLGRID(1,LB) + NR(2)*VCLGRID(2,LB) +
     $            NR(3)*VCLGRID(3,LB) - NR(4)
	    ENDIF
	    IF (ABS(DIST) .LE. DTOL) THEN
	       GO TO 40
            ELSE IF (DIST .GT. 0.0D0) THEN
	       SB = 1
            ELSE
	       SB = -1
            ENDIF
	    T = (VCLGRID(M,L) - PT(M))/DIR(M)
	    IF (ABS(T) .LE. DTOL) THEN
	       INOUT = 0
	       RETURN
	    ENDIF
	    IF (LA .NE. L) THEN
	       TA = (VCLGRID(M,LA) - PT(M))/DIR(M)
	       IF (ABS(TA) .LE. DTOL .OR. T*TA .LT. 0.0D0) THEN
	          INOUT = 0
	          RETURN
	       ENDIF
	    ENDIF
	    IF (SA*SB .LT. 0 .AND. T .GT. 0.0D0) K = K + 1
	 ENDIF
         I = I + 1
         IF (I .GT. NVERG) I = 1
      IF (I .NE. N) GO TO 30
C
C     Point lies inside polygon if number of intersections K is odd.
C
      IF (MOD(K,2) .EQ. 1) THEN
	 INOUT = 1
      ELSE
	 INOUT = -1
      ENDIF
      END
C
C
	FUNCTION FNTRUNC (A,AMED,AMAX,SIGMA)
C
C     **************************************************
C       FUNCION PARA CALCULAR PROBABILIDAD DE EXCEDENCIA
C       EN UNA LOG-NORMAL (AMED,SIGMA), TRUNCADA A AMAX
C     ************************************************* 
	ARG1=LOG(A/AMED)/SIGMA
	IF (AMAX .GT. 0) THEN
		IF (A .GE. AMAX ) THEN
			FNTRUNC=0.0
		ELSE
			ARG2=LOG(AMAX/AMED)/SIGMA
			FNTRUNC=1.0-FNORAC(ARG1)/FNORAC(ARG2)
		ENDIF
	ELSE
	    FNTRUNC=1.0-FNORAC(ARG1)
	ENDIF
	RETURN
	END

C	 *************************************************
	FUNCTION PLANO(IPLANO,NV,XYZ,XYTMP) 

      PARAMETER (MODMAX=5,NCMAX=20,NTMAX=15,NREGMAX=200,NMAGMAX=10,
     .           NRMAX=21,NMCX=4000,NMMAX=30,NVMAX=25,
     .           NTRIMAX=NREGMAX*NVMAX,NPGMAX=10,NVGMAX=30)     

C	Si Iplano=1 se revisa en X-Y
C	Si Iplano=2 se revisa en X-Z
C	Si Iplano=3 se revisa en Y-Z

	INTEGER I,J,K
			
	REAL x1,y1,Z1
	REAL x3,y3,Z3
	REAL Compi,Compj,Compk,norma,N1,N3
	REAL XYZ(3,NVMAX),XYTMP(3,NVMAX)	
 
	PLANO = 0
 
	DO I=1,3
		DO J=1,NV
			XYTMP(I,J)=XYZ(I,J)

		END DO
	ENDDO

	IF (IPLANO .EQ. 2) THEN
		DO J=1,NV
			XYTMP(2,J)=-XYZ(3,J)
		ENDDO
	ENDIF

	IF (IPLANO .EQ. 3) THEN
		DO J=1,NV
			XYTMP(1,J)=XYZ(2,J)
			XYTMP(2,J)=-XYZ(3,J)
		ENDDO
      ENDIF
	 
	DO I=1,NV 

		j = i + 1
		If (j .GT.Nv) j = 1
		k = j + 1
		If (k .GT.Nv) k = 1
C		Pivoteamos en el vértice j
		x1 = XYTMP(1,i) - XYTMP(1,j)
		Y1 = XYTMP(2,i) - XYTMP(2,j)
		Z1 = XYTMP(3,i) - XYTMP(3,j)
		N1=SQRT(X1**2+Y1**2+Z1**2)
		x3 = XYTMP(1,K) - XYTMP(1,j)
		Y3 = XYTMP(2,K) - XYTMP(2,j)
		Z3 = XYTMP(3,K) - XYTMP(3,j)
		N3=SQRT(X3**2+Y3**2+Z3**2)

   		IF (N3 .EQ. 0.0 .OR. N1 .EQ. 0) THEN
			PLANO=0
			RETURN
		ENDIF

C		Calculamos componentes del producto cruz
		Compi = y1 * Z3 - y3 * Z1
		Compj = -(x1 * Z3 - x3 * Z1)
		Compk = x1 * y3 - x3 * y1
		Norma = SqrT(Compi ** 2 + Compj**2 + Compk**2)
   
		If (Norma .EQ. 0) Then
C			LOS PUNTOS SON COLINEALES EN EL PLANO QUE SE REVISA
		ELSE
			Compi = Compi / Norma
			Compj = Compj / Norma
			Compk = Compk / Norma
			If( Abs(Compk) .LT. 0.000001) Then
				Plano = 0
				RETURN
			ENDIF
		End If
 
	ENDDO
 
	Plano = 1

	RETURN
	END
c
      FUNCTION NUMERA (NV,C)
c
C	Funcion para verificar si la numeracion de una region es correcta
C	Regresa -1 si la numeración es antihoraria y 0 si es horaria
	REAL C(3,NV)
	
      If (Nv .LT. 3) Then
		Numera=0
		RETURN
	End If
 
	DO i = 1,Nv
 
		j = i + 1
		If (j .GT. Nv) j = 1
		k = j + 1
		If (k .GT. Nv) k = 1

C		Calculamos centro del círculo
		CALL Circum (C(1,I),C(2,I),C(1,J),C(2,J),C(1,K),C(2,K),
     .				 X0,Y0,R)
   

c     Vemos si no son colineales
		If(r .gt.0.0 .And. r .lt. 100000) Then
   
c		   	No son colineales

c			Calculamos sentido del angulo
			x1 = C(1,I) - C(1,J)
			x3 = C(1,K) - C(1,J)
			y1 = C(2,I) - C(2,J)
			y3 = C(2,K) - C(2,J)
			Area = x1 * y3 - x3 * y1

			If (Area .lt. 0) Then

				x1 = C(1,I) - x0
				x2 = C(1,J) - x0
				x3 = C(1,K) - x0
				y1 = C(2,I) - y0
				y2 = C(2,J) - y0
				y3 = C(2,K) - y0
				alfa1 = Atn2(x1, y1)
				s = Sin(alfa1)
				CC = Cos(alfa1)
				xp1 = CC * x1 + s * y1
				xp2 = CC * x2 + s * y2
				xp3 = CC * x3 + s * y3
				yp1 = -s * x1 + CC * y1
				yp2 = -s * x2 + CC * y2
				yp3 = -s * x3 + CC * y3
      
				alfa2 = Atn2(xp2, yp2)
				alfa3 = Atn2(xp3, yp3)
				If (alfa2 .LT. alfa3) Then
					Numera=-1
				Else
					Numera=0
				End If
				RETURN
      
			End If

		endif

     	enddo
  
	Numera=0
	return
	end
c
	FUNCTION ATN2(X,Y)
	DATA Pi/3.141592654/
 
C	Excepciones
	If (x .EQ. 0.0) Then
		IF (Y .GT. 0.0) THEN
			Atn2 = Pi / 2
		ELSE
     			IF (Y .LT. 0.0) THEN
				Atn2 = 3 * Pi / 2
			ELSE
				ATN2=0.0
			ENDIF
		ENDIF
		RETURN
	End If

	If (Y .EQ. 0.0) Then
		IF (X .GT. 0.0) THEN
			Atn2 = 0.0
		ELSE
     			IF (X .LT. 0.0) THEN
				Atn2 = Pi 
			ELSE
				ATN2=0.0
			ENDIF
		ENDIF
		RETURN
	End If 
 
 
	IF (X .GT. 0.0) THEN
	    If (y .GT. 0.0) Then
C			Primer cuadrante
			Atn2 = Atan(y / x)
		Else
C			Cuarto cuadrante
			Atn2 = 2 * Pi - Atan(Abs(y / x))
     		end If
	else
		If (y .gt. 0.0) Then
c			Segundo cuadrante
			Atn2 = Pi - Atan(Abs(y / x))
		else
c			Tercer cuadrante
			Atn2 = Pi + Atan(Abs(y / x))
		End If
	End if
   	return
	End 

	FUNCTION OURLEN(A)
	CHARACTER*200 A
	N=LEN(A)

	DO I=1,N
		IF (A(I:I) .EQ. ' ') THEN
			OURLEN=I-1
			RETURN
		ENDIF
	ENDDO

	OURLEN=N
	RETURN
	END
C
	SUBROUTINE CIERRA()
	CLOSE (15)
	CLOSE (16)
	CLOSE (7)
	CLOSE (8)
	CLOSE (9)
	CLOSE (25)
	DO I=1,15
		CLOSE(26+I)
	ENDDO
	RETURN
	END
