c$DEBUG
c
c  changes
c
c  jun 99 jh   : ---------  version 7.0 -------------------
c  sep 27 bmt  : output file format
c                add version number
      PROGRAM ATNOR
      DIMENSION AF(3000),PARS(11),rr(30),TT(30)
      DIMENSION AC(10,50,50)
      DIMENSION SLA(30)
      CHARACTER*30 AD,at
      REAL MMIN,MMAX,MAG
      COMMON/FREC/FFI,FFF,NF,DFF
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

c
      WRITE (*,*) 'GIVE INPUT FILE NAME '
      READ (*,5000) AD
      WRITE (*,*) 'GIVE TABLE FILE NAME '
      READ (*,5000) At
5000  FORMAT ( A )
      OPEN (5,FILE=AD,STATUS='OLD')
      OPEN (7,FILE=at,STATUS='UNKNOWN')
C
      READ (5,5200) NTM
      WRITE (*,*) NTM
      READ (5,5100) (PARS(I),I=1,11)
      write (*,6000) (pars(i),i=1,11)
      READ (5,5100) RMIN,RMAX,MMIN,MMAX,TMIN,TMAX
      write (*,6000) rmin,rmax,mmin,mmax,tmin,tmax
      READ (5,5200) MR,NM,MT
      write (*,5200) mr,nm,mt
      NR=ABS(MR)
      IF (MR .LT. 0) READ (5,5100) (RR(I),I=1,NR)
5100  FORMAT (10F8.0)
5200  FORMAT (10I8)
      NT=ABS(MT)
      IF (MT .LT. 0) READ (5,5100) (TT(I),I=1,NT)
      READ (5,5100) (SLA(I),I=1,NT+1)
C
      FFI=0.02
      FFF=50.
      NF=300
      DFF=(FFF-FFI)/(NF-1)
      DR=(RMAX-RMIN)/(NR-1)
      DM=(MMAX-MMIN)/(NM-1)
      IF (NT .GT. 1) DT=(TMAX-TMIN)/(NT-1)
      WRITE (7,7300) MMIN,DM*(NM-1)+MMIN,NM
      WRITE (7,7301) RMIN,DR*(NR-1)+RMIN,NR
7300  FORMAT (4X,F6.4,2X,F7.4,4X,I5)
7301  FORMAT (4X,F6.4,2X,F8.4,4X,I5)
C

      DO 50 J=1,NM
        MAG=MMIN+(J-1)*DM
        PARS(8)=MAG
        DO 100 I=1,NR
          write (*,*) j,i
          IF (MR .GT. 0) THEN      
             R=RMIN+(I-1)*DR
          ELSE
             R=RR(I)
          ENDIF
          PARS(9)=R   
          IF (NTM .EQ.1) THEN
            CALL MODNO1 (PARS,AF,TS,11)      
          ELSE
            CALL MODNO2 (PARS,AF,TS,11)
          ENDIF
          DO 30 K=1,NT
             IF (MT .GT. 0) THEN
                T=TMIN+(K-1)*DT
             ELSE
                T=TT(K)
             ENDIF
             F0=1./T
             CALL MOMEN (NF,F0,FFI,0.05,DFF,AF,NF,AM0,AM2,AM4)
             CALL AMAXA (AM0,AM2,AM4,TS,F0,0.05,T,ACMAX,VAR,0)
             AC(K,J,I)=ACMAX
30        CONTINUE
C
          CALL ESPVEL (AF,FFI,DFF,NF)
          CALL MOMEN (NF,50.,FFI,0.05,DFF,AF,NF,AM0,AM2,AM4)
          CALL AMAXA (AM0,AM2,AM4,TS,50.,0.05,0.02,VMAX,VAR,0)         
          AC(NT+1,J,I)=VMAX
7000      FORMAT (8(1PE10.3))
6000      FORMAT (7(1PE11.3,1X))              
100     CONTINUE
50    CONTINUE
C
      DO 680 J=1,1
        write (7,'(4X,F6.4,2X,F6.4,2X,I3)') 0.005,SLA(J),500
c        WRITE (7,*) SLA(J)
        DO 660 K=1,NM
          WRITE (7,'(20F10.4)') (AC(J,K,L),L=1,NR)
660	 CONTINUE
680   CONTINUE
C	
C
      CLOSE(5)
      CLOSE(7)
      STOP
      END
C********************************************************************
      SUBROUTINE MODNO1 (PARS,A,TS,NPAEF)
      COMMON/FREC/FFI,FFF,NF,DFF
C
      DIMENSION A(NF),PARS(NPAEF)
C
C     PARS(11)=COEFICIENTE DE LA DURACION, =0.05 O 0.07
C      
      DATA PI/3.14159264/
      DS=PARS(1)
      Q0=PARS(2)
      EX=PARS(3)
      VEL=PARS(4)*100000.
      DNS=PARS(5)
      FM=PARS(6)
      S=PARS(7)
      EMC=10.**(1.5*(PARS(8)+10.7))
      R=PARS(9)*100000.
c
      RFP=0.55*PARS(10)*0.71
      CE=RFP/4.0/PI/DNS/VEL/VEL/VEL
c
      FC=49.1*VEL*(DS/EMC)**(1./3.)
      TS=1./FC+PARS(11)*PARS(9)
c
      IF (PARS(9) .LT. 100.) THEN
        GR=1./R
      ELSE
        GR=1./SQRT(100*PARS(9))/100000.
      ENDIF
C
      DO 200 LL=1,NF
         FIF=FFI+(LL-1)*DFF
         QU=Q0*FIF**EX
         XE=EXP(-PI*FIF*R/QU/VEL)
         XE=XE*GR
         SF1=4.0*PI*PI*FIF*FIF
         SF2=1.0+(FIF/FC)**2
         SF=SF1/SF2
         PF=(1.0+(FIF/FM)**(2*S))**(-0.5)
  200    A(LL)=CE*EMC*SF*PF*XE
      RETURN
      END
c
c*********************************************************************
      SUBROUTINE MODNO2 (PARS,A,TS,NPAEF)
      COMMON/FREC/FFI,FFF,NF,DFF
C
      REAL K,K0,K1
      DIMENSION A(NF),PARS(NPAEF)
C
C     PARS(11)=COEFICIENTE DE LA DURACION, =0.05 O 0.07
C     PARS( 6)=Ko
C     PARS( 7)=K1
C
C     PARAMETROS DE ATENUACION DE SITIO:   K = Ko + K1*R (R en km)
C      
      DATA PI/3.14159264/
      DS=PARS(1)
      Q0=PARS(2)
      EX=PARS(3)
      VEL=PARS(4)*100000.
      DNS=PARS(5)
      K0=PARS(6)
      K1=PARS(7)
      K=K0+K1*PARS(9)
      EMC=10.**(1.5*(PARS(8)+10.7))
      R=PARS(9)*100000.
c
      RFP=0.55*PARS(10)*0.71
      CE=RFP/4.0/PI/DNS/VEL/VEL/VEL
c
      FC=49.1*VEL*(DS/EMC)**(1./3.)
      ts=1./Fc+PARS(9)*pars(11)
c
      IF (PARS(9) .LT. 100.) THEN
        GR=1./R
      ELSE
        GR=1./SQRT(100*PARS(9))/100000.
      ENDIF
C
      DO 200 LL=1,NF
         FIF=FFI+(LL-1)*DFF
         QU=Q0*FIF**EX
         XE=EXP(-PI*FIF*R/QU/VEL)
         XE=XE*GR
         SF1=4.0*PI*PI*FIF*FIF
         SF2=1.0+(FIF/FC)**2
         SF=SF1/SF2
         PF=EXP(-PI*K*FIF)
  200    A(LL)=CE*EMC*SF*PF*XE
      RETURN
      END
c
C*************************************************************************
C
      SUBROUTINE ESPVEL (AF,FFI,DFF,NF)
      DIMENSION AF(NF)
C
      DATA PI/3.141592654/
C
      DO 100 I=1,NF
       F=FFI+(I-1)*DFF
       AF(I)=AF(I)/(2.*PI*F)
100   CONTINUE
      RETURN
      END

      SUBROUTINE QTRAP (FUNC,A,B,S)
      DOUBLE PRECISION A,B,S,EPS,OLDS
      DOUBLE PRECISION FUNC
      EXTERNAL FUNC
      PARAMETER (EPS=1.D-4, JMAX=20)
      OLDS=-1.0D30
      DO 11 J=1,JMAX
	   CALL TRAPZD (FUNC,A,B,S,J)
C	   WRITE (*,*) 'J,S ',J,S
C	   PAUSE
	   IF (DABS(S-OLDS) .LT. EPS*DABS(OLDS)) RETURN
	   OLDS=S
11    CONTINUE
      WRITE (*,1000)
      RETURN
1000  FORMAT ('  *****  WARNING: POSSIBLE LACK OF PRECISION IN INTEGRATI
     *                  ON, SUBROUTINE QTRAP  ****')
      END
C  
c$PAGE
      SUBROUTINE TRAPZD (FUNC,A,B,S,N)
      EXTERNAL FUNC
      DOUBLE PRECISION A,B,S,SUM,X,DEL
      DOUBLE PRECISION FUNC
      IF (N .EQ. 1) THEN
	    S=0.5*(B-A)*(FUNC(A)+FUNC(B))
           IT=1
      ELSE
	    TNM=IT
           DEL=(B-A)/TNM
	    X=A+0.5*DEL
	    SUM=0.0
	    DO 11 J=1,IT
		  SUM=SUM+FUNC(X)
		  X=X+DEL
11         CONTINUE
           S=0.5*(S+(B-A)*SUM/TNM)
	    IT=2*IT
      ENDIF
      RETURN
      END			  		
C
C***********************************************************************
C	  SUBROUTINE TO EVALUATE THE GAUSSIAN PROBABILITY DISTRIBUTION	  
C	  TAKEN FROM ABRAMOWITZ AND STEGUN, HANDBOOK OF MATHEMATICAL
C	  FUNCTIONS, PAGE 932. SHOULD HAVE BEEN A FUNCTION, NOT A SUB-
C	  ROUTINE, BUT THINGS WILL GET CLEARER SOME DAY. (NOVEMBER, 1991)
C
	  SUBROUTINE MDNOR (ARG,P)
	  REAL B(5)
	  DATA B/0.319381530,-0.356563782,1.781477937,
     1      -1.821255978, 1.330274429/
	  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
	    P=1.0-S
	  ELSE
	  	P=S
	  ENDIF
	  RETURN
	  END					  
C********************************************************************
      SUBROUTINE MOMEN (NFIN,F0,FFI,Z,DFF,A,NE,AMOM0,AMOM2,AMOM4)
      DIMENSION A(NE)
      DATA PI/3.141592654/
      Z1=FFI/F0
      FMAX=FFI+(NFIN-1)*DFF
      ZM=FMAX/F0
      H1=1./((1.-Z1*Z1)**2+4.*Z*Z*Z1*Z1)
      HM=1./((1.-ZM*ZM)**2+4.*Z*Z*ZM*ZM)
      AMOM0=(A(1)**2*H1+A(NFIN)**2*HM)/2.
      AMOM2=(A(1)**2*H1*FFI**2+A(NFIN)**2*HM*FMAX**2)/2.
      AMOM4=(A(1)**2*H1*FFI**4+A(NFIN)**2*HM*FMAX**4)/2.
      DO 1410 I=2,NFIN-1
       F=FFI+(I-1)*DFF
       Z2=F/F0
       H2=1./((1-Z2*Z2)**2+4*Z*Z*Z2*Z2)
       AMOM0=AMOM0+A(I)**2*H2
       AMOM2=AMOM2+A(I)**2*H2*F**2
       AMOM4=AMOM4+A(I)**2*H2*F**4
 1410 CONTINUE
      P=2*PI
      AMOM0=AMOM0*P/PI*DFF
      AMOM2=AMOM2*P*P*P/PI*DFF
      AMOM4=AMOM4*P*P*P*P*P/PI*DFF
      RETURN
      END
c$PAGE
C********************************************************************
      SUBROUTINE AMAXA (AM0,AM2,AM4,TS,F0,Z,T0,ACMAX,VAR,IND)
      DOUBLE PRECISION FPMAX,EPS,EMAX,EMAX2
      REAL K
      EXTERNAL FPMAX
      COMMON/MAX/EPS,M,NC
      DATA PI,C/3.141592654,0.577215665/
C
      GAMA=TS*F0
      TRMS=TS+(1./Z/F0/2./PI*GAMA**3/(GAMA**3+1./3.))
      ARMS=SQRT(AM0/TRMS)
C
      EPS=SQRT(1.-(AM2**2/AM0/AM4))
      R=0.5*(1.-SQRT(1.-EPS*EPS))
      FM=SQRT(AM4/AM2)/2./PI
C
      ANC=2*FM*TRMS
      NC=ANC
C
C     CUANDO NC .LT. 2, EL ACELEROGRAMA CUYO MAXIMO SE DESEA CALCULAR
C     SE VULEVE INCONCEBIBLE. LA SOLUCION TEORICA EXISTE AUN CUANDO
C     NC = 0, PERO ME PARECE QUE NO TIENE SENTIDO. POR ESTA RAZON SE
C     IMPONE LA SIGUIENTE CONDICION:
C
      IF (NC .LT. 2) NC=2
C
C
      K=SQRT(1.-EPS*EPS)*ANC
      Q=2*ALOG(K)
C     WRITE(*,6100) T0,AM0,AM2,AM4
C     WRITE(*,6200) TRMS,NC,FM,EPS,K,Q
6100  FORMAT (5X,'T0=',F6.3,' MOMENTOS 0,2,4:  ',3(1X,1PE11.4))
6200  FORMAT  (5X,'TRMS = ',F8.3,' NC= ',I5,' FM= ',1PE11.4/
     1         5X,'EPS  = ',1PE11.3,' K = ',1PE11.3,' Q= ',1PE11.3)
      
C
      IF (IND .EQ. 0) THEN
        IF (Q .LE. 2) THEN
C         
C         SE CONSIDERA QUE PARA Q<2 LA APROXIMACION ASINTOTICA NO ES
C         VALIDA, ESPECIALMENTE PARA EL SEGUNDO MOMENTO. LOS VALORES
C         DADOS POR LA APROXIMACION SE CALCULAN SOLO COMO REFERENCIA
C         Y PARA PROBAR QUE TAN BUENA ES LA APROXIMACION.
C
          IF (Q .GT. 0.0) THEN
           ACAP =SQRT(Q)+C/SQRT(Q)
           ACAP2=PI/SQRT(6.0)/SQRT(Q)
           ACAP2=ACAP2*ACAP2+ACAP*ACAP
           ACAP =ACAP*ARMS
           ACAP2=ACAP2*ARMS**2
          ENDIF
C                
C
          WRITE(*,6000) T0,Q,EPS,NC
          M=1
          CALL QTRAP (FPMAX,-5D0,5D0,EMAX)
          M=2
          CALL QTRAP (FPMAX,-5D0,5D0,EMAX2)
        ELSE
          EMAX=SQRT(Q)+C/SQRT(Q)
          EMAX2=PI/SQRT(6.0)/SQRT(Q)
          EMAX2=EMAX2*EMAX2+EMAX*EMAX
        ENDIF
      ELSE
        M=1
        CALL QTRAP (FPMAX,-5D0,5D0,EMAX)
        M=2
        CALL QTRAP (FPMAX,-5D0,5D0,EMAX2)
      ENDIF
C
      ACMAX=EMAX*ARMS
      VAR=EMAX2*ARMS**2
C
      RETURN
C
6000  FORMAT('*******************************************************'/
     1       ' ADVERTENCIA DESDE AMAX: NO ES POSIBLE USAR APROX.'/
     2       ' T0,Q,EPS,NC: ',3(1PE11.3,1X),I5/
     3       '*******************************************************')

      END
C
C*************************************************************
      FUNCTION FPMAX(X)
      IMPLICIT DOUBLE PRECISION (A-H,P-Z)
      DOUBLE PRECISION K
      COMMON/MAX/EPS,MOM,NC
      DATA PI/3.141592654D0/
      K=DSQRT(1D0-EPS*EPS)
      O1=X/EPS
      O2=X*K/EPS
      CALL MDNOR (O1,OP1)
      FIA1=OP1
      CALL MDNOR (O2,OP2)
      FIA2=OP2
      FI3=FI(X)
      FI2=FI(X*K/EPS)
      FI1=FI(X/EPS)
      P=NC*(FIA1-DSQRT(2D0*PI)*K*FI3*FIA2)**(NC-1)
      Q=FI1/EPS+DSQRT(2D0*PI)*K*FI3*( X*FIA2-FI2*K/EPS )
      FPMAX=P*Q*X**MOM
C     WRITE(*,6000) N,E,M,X,FPMAX
6000  FORMAT(3X,'DESDE FPMAX ',I5,1PE11.3,I5,1PE11.3,1X,1PE11.3)
      RETURN
      END
C********************************************************
      FUNCTION FI(X)
      DOUBLE PRECISION X,PI,FI
      DATA PI/3.141592654D0/
      IF (X .GT. 14.0D0) THEN
        FI=0.0D0
        RETURN
      ELSE
        FI=1D0/DSQRT(2D0*PI)*DEXP(-X*X/2D0)
      ENDIF
      RETURN
      END
C**********************************************************
