      PROGRAM RELAX6
$NOFLOATCALLS
$LARGE
      COMPLEX A(4,4,6),B(2,2,6),EIFI,ISV(48,48),SPU(48,48),
     1W(6,6),IM,PW(6),SPQM(2,4,2,4),Z,EIEPSZ,SV(48,48),SE(48),
     2D(48,48),TEMP,SEO(48),AP(2,2,4),SP(6,2,4,6,2,4),SPQ,Z01,Z02
      DIMENSION Q(6),TETA(6),FI(6),ETA(6),H(6),ENES(6),POPES(6),
     1SS(256),CHEM(6),ETETA(6),EPSZI(6),EFI(6),PWR(6),TRAP(6,6),
     2RM(6,6),RMI(6,6),SSC(256)
      CHARACTER*12 DATAFN,ISPFN,OSPFN
      CHARACTER*1 ANS
      CHARACTER*72 STIT
      EQUIVALENCE (SPU(1,1),SP(1,1,1,1,1,1))
      common /cmenu/IANS,ANS,DATAFN,ISPFN,OSPFN,STIT
C
C     **************************    START   ***************************
C
      WRITE(*,600)
 600  FORMAT(////////////,35X,'R E L A X 6',/,37X,'by mm/s',/////,12X,
     1'Program for computing M”ssbauer-spectrum of relaxing iron ',
     2////,30X,'Press ENTER to begin',////)
      READ(*,'(A)') ANS
      ANS='N'
C
C     **************************    MENU    ***************************
C
      IANS=0
   1  CALL MENU
      IF ((ANS.EQ.'Y').OR.(ANS.EQ.'y')) GO TO 100
      IF (IANS.EQ.2) GOTO 8
      OPEN(3,FILE='RELAX6.UNF',STATUS='NEW',FORM='UNFORMATTED')
   8  OPEN(6,FILE='LPT1')
      WRITE(6,603) STIT,DATAFN,OSPFN
 603  FORMAT('1',34X,'R E L A X 6'//36X,'by mm/s'/////
     1' SPECTRUM TITLE : ',A72,/
     2' INPUT DATA-FILE : ',A12,//
     3' OUTPUT SPECTRUM FILE : ',A12,//)
      IF (IANS.EQ.1) GOTO 2
      IF (IANS.EQ.2) GOTO 9
      WRITE(6,'(A)') ' EMISSION SPECTRUM'
      WRITE(6,'(A)') ' *****************'
      GOTO 3
  2   WRITE(6,'(A)') ' ABSORPTION SPECTRUM'
      WRITE(6,'(A)') ' *******************'
      GOTO 3
  9   WRITE(6,'(A)') ' CALCULATION OF AVERAGE POPULATIONS'
      WRITE(6,'(A)') ' **********************************'
C
C     ************************** DATA INPUT ***************************
C
  3   OPEN(1,FILE=DATAFN,STATUS='OLD',FORM='FORMATTED')
      READ(1,620)TEMPER,NCHAN,REF,DELTA,REFGAM,TETAP,FIAP,H,TETA,FI,
     1         Q,ETA,ETETA,EPSZI,EFI,CHEM,ENES,POPES,TRAP(2,1),
     2         TRAP(3,1),TRAP(3,2),TRAP(4,1),TRAP(4,2),TRAP(4,3),
     3         TRAP(5,1),TRAP(5,2),TRAP(5,3),TRAP(5,4),TRAP(6,1),
     4         TRAP(6,2),TRAP(6,3),TRAP(6,4),TRAP(6,5)
 620  FORMAT(7X,F10.5/,7X,I3/,5(7X,F10.5/),11(7X,5(F10.5,1X),F10.5/),
     1       7X,F10.5/,
     2       7X,F10.5,1X,F10.5/,7X,2(F10.5,1X),F10.5/,7X,3(F10.5,1X),
     3       F10.5/,7X,4(F10.5,1X),F10.5)
      CLOSE(1,STATUS='KEEP')
      WRITE(*,630)TEMPER,NCHAN,REF,DELTA,REFGAM,TETAP,FIAP,H,TETA,FI,
     1            Q,ETA,ETETA,EPSZI,EFI,CHEM,ENES,POPES,
      WRITE(6,630)TEMPER,NCHAN,REF,DELTA,REFGAM,TETAP,FIAP,H,TETA,FI,
     1            Q,ETA,ETETA,EPSZI,EFI,CHEM,ENES,POPES,
 630  FORMAT(/,31X,'INPUT PARAMETERS',/,
     1         31X,'****************',///,
     2' TEMPERATURE [K]:',25X,F10.5,/,' NUMBER OF CHANNELS :',25X,I3,/,
     3' VELOCITY OF THE FIRST CHANNEL [MM/S] :',3X,F10.5,/,
     4' CHANNEL WIDTH [MM/S] :',19X,F10.5,/,' FWHM [MM/S]:',29X,F10.5,/,
     5' POL. ANGLES OF THE OBS. DIR. - THETA :',3X,F10.5,/,
     630X,'- PHI   :',3X,F10.5,////,
     712X,'STATE-1',4X,'STATE-2',4X,'STATE-3',4X,'STATE-4',4X,
     8'STATE-5',4X,'STATE-6'/12X,'-------',4X,'-------',4X,'-------',
     94X,'-------',4X,'-------',4X,'-------',//,' H',7X,6(F10.5,1X),/,
     T' THETA-H',1X,6(F10.5,1X),/,' PHI-H',3X,6(F10.5,1X),/,
     1' Q.S.',4X,6(F10.5,1X),/,
     2' ETA',5X,6(F10.5,1X),/,' EFG-TH',2X,6(F10.5,1X),/,
     3' EFG-PSZ',1X,6(F10.5,1X),/,' EFG-PHI',1X,6(F10.5,1X),/,
     4' I.S.',4X,6(F10.5,1X),/,' E(EL)',3X,6(F10.5,1X),/,
     5' P0(EL)',2X,6(F10.5,1X),//)
C
C     *****************************************************************
C
      TAUP=.0728254
      TAUN=141.
      GAMMAF=0.5/TAUN/TAUP
      SQ3=SQRT(3.)
      SQ32=SQ3/2.
      IM=(0.,1.)
      ALFAP=-.00678522
      BETAP=.0118694
C
C     ********************** TRANSITION PROBABILITIES *****************
C
      DO 4 I=1,6
      DO 4 J=1,6
      IF((I.GT.J).OR.(I.EQ.J)) GOTO 4
      SJI=EXP((ENES(J)-ENES(I))/TEMPER/.69503)
      TRAP(I,J)=SJI*TRAP(J,I)
   4  CONTINUE
      DO 6 I=1,6
      TRAP(I,I)=0.
      DO 5 J=1,6
      IF(I.EQ.J) GOTO 5
      TRAP(I,I)=TRAP(I,I)+TRAP(J,I)
   5  CONTINUE
      TRAP(I,I)=-TRAP(I,I)
   6  CONTINUE
      WRITE(*,635)((TRAP(I,J),J=1,6),I=1,6)
      WRITE(6,635)((TRAP(I,J),J=1,6),I=1,6)
  635 FORMAT(//,20X,'ELECTRON TRANSITION PROBABILITIES  [MHz]',
     1//,6(9X,6(F10.5,1X)/))
      DO 7 I=1,6
      DO 7 J=1,6
   7  TRAP(I,J)=TRAP(I,J)/1000.
      IF (IANS.EQ.2) GOTO 11
C     *****************************************************************
      DO 10 J=1,256
  10  SS(J)=0.
      AP(1,2,1)=(0.,0.)
      AP(1,1,4)=(0.,0.)
      AP(2,2,1)=(0.,0.)
      AP(2,1,4)=(0.,0.)
      AP(1,1,1)=CEXP(CMPLX(0.,FIAP))*0.5*(1.+COS(TETAP))
      AP(2,1,1)=CEXP(CMPLX(0.,FIAP))*0.5*(1.-COS(TETAP))
      AP(1,2,4)=CEXP(CMPLX(0.,-FIAP))*0.5*(1.-COS(TETAP))
      AP(2,2,4)=CEXP(CMPLX(0.,-FIAP))*0.5*(1.+COS(TETAP))
      AP(1,2,2)=AP(1,1,1)/SQ3
      AP(2,2,2)=AP(2,1,1)/SQ3
      AP(1,1,3)=AP(1,2,4)/SQ3
      AP(2,1,3)=AP(2,2,4)/SQ3
      AP(2,2,3)=CMPLX(SIN(TETAP)/SQ3,0.)
      AP(2,1,2)=AP(2,2,3)
      AP(1,1,2)=-AP(2,2,3)
      AP(1,2,3)=-AP(2,2,3)
C
C     ************** OBTAIN HAMILTONIAN MATRICES (A AND B) ************
C
      DO 20 I=1,6
      AST=SIN(TETA(I))
      ACT=COS(TETA(I))
      EIFI=CEXP(CMPLX(0.,FI(I)))
      ALFA=ALFAP*H(I)
      BETA=BETAP*H(I)
      QA=Q(I)/6.
      BST=BETA*AST/2.
      BCT=BETA*ACT/2.
      AST=ALFA*AST
      ACT=ALFA*ACT/2.
      EIEPSZ=CEXP(CMPLX(0.,EPSZI(I)))
      S2ET=SIN(ETETA(I))**2
      CEF=COS(EFI(I))
      SEF=SIN(EFI(I))
      CET=COS(ETETA(I))
C
C     ********************* GROUND STATE MATRIX (B) *******************
C
      B(1,1,I)=CMPLX(BCT-CHEM(I),0.)
      B(1,2,I)=-BST*EIFI
      B(2,1,I)=CONJG(B(1,2,I))
      B(2,2,I)=CMPLX(-BCT-CHEM(I),0.)
C
C     ********************* EXCITED STATE MATRIX (A) ******************
C
      A(1,4,I)=(0.,0.)
      A(4,1,I)=(0.,0.)
      A(1,3,I)=QA*SQ32*(-3.*S2ET+ETA(I)*(CMPLX(CEF,SEF*CET)**2
     1                     -CMPLX(-SEF,CEF*CET)**2))*EIEPSZ**2
      A(2,4,I)=A(1,3,I)
      A(3,1,I)=CONJG(A(1,3,I))
      A(4,2,I)=A(3,1,I)
      A(2,3,I)=-AST*EIFI
      A(3,2,I)=CONJG(A(2,3,I))
      A(1,2,I)=SQ32*A(2,3,I)+QA*SQ3*(1.5*IM*SIN(2.*ETETA(I))-ETA(I)*
     1(CMPLX(CEF,SEF*CET)*SEF-CMPLX(-SEF,CEF*CET)*CEF)*SIN(ETETA(I)))*
     2EIEPSZ
      A(3,4,I)=-A(1,2,I)+SQ3*A(2,3,I)
      A(2,1,I)=CONJG(A(1,2,I))
      A(4,3,I)=CONJG(A(3,4,I))
      FF=6.*ETA(I)*S2ET*COS(2.*EFI(I))
      Z=CMPLX(0.25*QA*(27.*COS(ETETA(I))**2+9.*S2ET-15.-FF),0.)
      A(1,1,I)=Z+3.*ACT
      A(4,4,I)=Z-3.*ACT
      Z=CMPLX(0.25*QA*(3.*COS(ETETA(I))**2+21.*S2ET-15.+FF),0.)
      A(2,2,I)=Z+ACT
  20  A(3,3,I)=Z-ACT
C
C     *************** DETERMINE STOCHASTIC MATRIX ELEMENTS (W) ********
C
      DO 22 I=1,6
      DO 22 J=1,6
  22  W(I,J)=CMPLX(TRAP(J,I)/TAUP,0.)
C
C     ***************** CALC. OF THE AVERAGE POPULATIONS **************
C
      IF(IANS.EQ.1) GOTO 130
C     ***** EMISSION SPECTRUM (IANS=0) AND AV. POPS (IANS=2)
  11  DO 92 I=1,6
      DO 92 J=1,6
  92  RM(I,J)=-TRAP(I,J)
      DO 93 I=1,6
  93  RM(I,I)=RM(I,I)+1./TAUN
      DO 94 I=1,6
      DO 94 J=1,6
  94  RMI(I,J)=0.
      DO 95 I=1,6
  95  RMI(I,I)=1.
      CALL LEQT2F(RM,6,6,6,RMI,5,54,IER)
      DO 98 I=1,6
      SUM=0.
      DO 97 J=1,6
  97  SUM=SUM+RMI(I,J)*POPES(J)
      PWR(I)=SUM/TAUN
  98  PW(I)=CMPLX(PWR(I),0.)
      IF(IANS.EQ.2) GOTO 12
      GOTO 24
C     ***** ABSORBTION SPECTRUM (IANS=1)
 130  DO 131 I=1,6
 131  PW(I)=POPES(I)
      WRITE(*,132)
      WRITE(6,132)
 132  FORMAT(/,' The P0 input values were taken to be the average'
     1' BOLTZMANN population'/' of the electronic levels.'//)
      GOTO 24
  12  WRITE(*,133) PWR
      WRITE(6,133) PWR
 133  FORMAT(' Average population of the electronic levels:'//
     1       9X,6(F10.5,1X)/)
      IANS=0
      WRITE(*,650)
      READ(*,'(A)') ANS
      ANS='N'
      GOTO 1
C
C     ****************** OBTAIN RELAXATION MATRIX (SP=SPU) ************
C
  24  DO 25 I=1,48
      DO 25 J=1,48
  25  SPU(I,J)=(0.,0.)
      DO 45 I=1,6
      DO 45 J=1,2
      DO 45 K=1,4
      DO 30 KV=1,4
  30  SP(I,J,K,I,J,KV)=IM*A(KV,K,I)
      DO 35 JV=1,2
  35  SP(I,J,K,I,JV,K)=SP(I,J,K,I,JV,K)-IM*B(J,JV,I)
      DO 40 IV=1,6
  40  SP(I,J,K,IV,J,K)=SP(I,J,K,IV,J,K)-W(I,IV)
  45  SP(I,J,K,I,J,K)=SP(I,J,K,I,J,K)+CMPLX(GAMMAF,0.)
C     *************************** SPECTRUM ****************************
C
      WRITE(*,'(A)') '+Eigensystem analysis......'
      CALL CMATEIG(SPU,SV,SE)
      WRITE(*,'(A)') '+Matrix inversion......'
      CALL CMATINV(SV,ISV)
C           ******************** CHANNEL LOOP *******************
      WRITE(*,46) NCHAN
      WRITE(6,46) NCHAN
  46  FORMAT(/,1X,I3,'-channel spectrum computing in progress....',/)
      DO 90 L=1,NCHAN
      WRITE(*,47) L
  47  FORMAT('+',55X,'channel = ',I3)
      OMEGA=REF+(L-1)*DELTA
      DO 50 I=1,48
  50  SEO(I)=1./(SE(I)+CMPLX(0.,-OMEGA))
      DO 55 I=1,48
      DO 55 J=1,48
      D(I,J)=(0.,0.)
  55  D(I,J)=SV(I,J)*SEO(J)
      DO 65 I=1,48
      DO 65 J=1,48
      SPU(I,J)=(0.,0.)
      TEMP=(0.,0.)
      DO 60 K=1,48
  60  TEMP=TEMP+D(I,K)*ISV(K,J)
  65  SPU(I,J)=TEMP
C
C     ******* AVERAGE OVER THE STATISTICAL INDICES TO OBTAIN THE ******
C     ***************** QUANTUM-MECHANICAL MATRIX (SPQM) **************
C
      DO 75 J=1,2
      DO 75 K=1,4
      DO 75 JV=1,2
      DO 75 KV=1,4
  75  SPQM(J,K,JV,KV)=(0.,0.)
      DO 80 J=1,2
      DO 80 K=1,4
      DO 80 JV=1,2
      DO 80 KV=1,4
      SPQ=(0.,0.)
      DO 77 N=1,6
      DO 77 M=1,6
  77  SPQ=SPQ+PW(N)*SP(N,J,K,M,JV,KV)
  80  SPQM(J,K,JV,KV)=SPQ
C
C     ******************** OBTAIN THE SPECTRUM (SS) ******************
C
      Z=(0.,0.)
      DO 85 J=1,2
      DO 85 K=1,4
      Z01=AP(1,J,K)
      Z02=AP(2,J,K)
      DO 85 JV=1,2
      DO 85 KV=1,4
      IF(IABS(K-J-1).EQ.2.OR.IABS(KV-JV-1).EQ.2) GO TO 85
      Z=Z+(Z01*CONJG(AP(1,JV,KV))+Z02*CONJG(AP(2,JV,KV)))*
     1    SPQM(J,K,JV,KV)
  85  CONTINUE
  90  SS(L)=REAL(Z)/GAMMAF
      WRITE(*,'(A)') '+End of spectrum computing'
C
C     *********** CONVOLUTION ***********
C
      WRITE(*,680)
 680  FORMAT(/' Convolution computing'/)
      RGAM22=REFGAM*REFGAM/4.
      DO 120 I=1,256
 120  SSC(I)=0.
      DO 150 L=1,NCHAN
      WRITE(*,653) L
 653  FORMAT('+Channel :',I3)
      E0=REF+(L-1)*DELTA
      DO 150 I=1,NCHAN
      EI=REF+(I-1)*DELTA
 150  SSC(L)=SSC(L)+(RGAM22/(RGAM22+(EI-E0)*(EI-E0)))*SS(I)
C     *********** AMPLITUDES DOWN ***********
      SMAX=SSC(1)
      DO 160 I=2,NCHAN
      IF(SMAX.GT.SSC(I)) GOTO 160
      SMAX=SSC(I)
 160  CONTINUE
      DO 180 I=1,NCHAN
 180  SS(I)=(SMAX+0.00001-SSC(I))*100000.
C
C     ************************* DATA OUTPUT ***************************
C
      WRITE(6,642)
      WRITE(*,640) STIT,(SS(I),I=1,NCHAN)
      WRITE(6,640) STIT,(SS(I),I=1,NCHAN)
 640  FORMAT(//,1X,A72/,' RESULT SPECTRUM', //(8F10.0))
      CALL SPUT(SS,NCHAN,OSPFN,STIT)
C
C     *************************    EXIT     ***************************
C
      WRITE(6,642)
 642  FORMAT('1')
      WRITE(*,650)
 650  FORMAT(/20X,' Press ENTER to return to the menu')
      READ(*,'(A)') ANS
      ANS='N'
      GOTO 1
 100  CLOSE(1,STATUS='KEEP')
      CLOSE(3,STATUS='KEEP')
      CLOSE(6)
      CLOSE(9,STATUS='KEEP')
      STOP
      END
C
C     ************************ SUBROUTINE MENU ************************
C
      SUBROUTINE MENU
      CHARACTER*72 STIT
      CHARACTER*12 DATAFN,ISPFN,OSPFN
      CHARACTER*1 ANS,MANS
      common /cmenu/IANS,ANS,DATAFN,ISPFN,OSPFN,STIT
      CALL CLS
      ANS='N'
      MANS='N'
   2  WRITE(*,5)
   5  FORMAT(////,25X,'R E L A X 6 - M E N U',/,25X,
     1'---------------------',/////,20X,
     2'[1]  SPECTRUM TITLE SPECIFICATION',/,20X,
     3'[2]  INPUT DATA-FILE SPECIFICATION',/,20X,
     4'[3]  OUTPUT SPECTRUM-FILE SPECIFICATION',/,20X,
     5'[4]  COMPUTING EMISSION SPECTRUM',/,20X,
     6'[5]  COMPUTING ABSORBPTION SPECTRUM',/,20X,
     7'[6]  CALCULATING AVERAGE POPULATIONS',/,20X,
     8'[7]  QUIT',////,2X,'enter your choise: ')
      READ(*,'(A)') MANS
      IF ((ICHAR(MANS).LT.49).OR.(ICHAR(MANS).GT.55)) GO TO 50
      IF (MANS.EQ.'1') GO TO 100
      IF (MANS.EQ.'2') GO TO 200
      IF (MANS.EQ.'3') GO TO 300
      IF (MANS.EQ.'4') GO TO 400
      IF (MANS.EQ.'5') GO TO 450
      IF (MANS.EQ.'6') GO TO 500
      IF (MANS.EQ.'7') GO TO 350
  50  WRITE (*,55)
  55  FORMAT(//,15X,' ####  NOT VALID CHOISE  ####',//,2X,
     1'press ENTER to continue')
      READ(*,'(A)') MANS
      CALL CLS
      GO TO 2
 100  WRITE(*,'(A)') ' ENTER SPECTRUM TITLE <max. 72 char> :'
      READ(*,'(A)') STIT
      GO TO 2
 200  WRITE(*,'(A)') ' ENTER INPUT DATA-FILE NAME :'
      READ(*,'(A)') DATAFN
      GO TO 2
 300  WRITE(*,'(A)') ' ENTER OUTPUT SPECTRUM FILE NAME :'
      READ(*,'(A)') OSPFN
      GO TO 2
 350  WRITE(*,'(A)') ' Quit RELAX and return to DOS ?  [Y/N] :'
      READ(*,'(A)') ANS
      IF ((ANS.EQ.'Y').OR.(ANS.EQ.'y')) GO TO 420
      GO TO 2
 400  CALL CLS
      WRITE(*,'(A)') ' COMPUTING OF EMISSION MOSSBAUER SPECTRUM'
      WRITE(*,'(A)') ' ****************************************'
      WRITE(*,603) STIT,DATAFN,OSPFN
  603 FORMAT(//,' SPECTRUM TITLE : ',A72,/,
     1' INPUT DATA-FILE : ',A12,//,
     2' OUTPUT SPECTRUM FILE : ',A12,///,10X,
     3'LOOK AT THE INPUT OPTIONS !       O.K. ?   [Y/N]')
      READ(*,'(A)') MANS
      IF ((MANS.EQ.'Y').OR.(MANS.EQ.'y')) GO TO 420
      GO TO 2
 450  CALL CLS
      IANS=1
      WRITE(*,'(A)') ' COMPUTING OF ABSORBTION MOSSBAUER SPECTRUM'
      WRITE(*,'(A)') ' ******************************************'
      WRITE(*,603) STIT,DATAFN,OSPFN
      READ(*,'(A)') MANS
      IF ((MANS.EQ.'Y').OR.(MANS.EQ.'y')) GO TO 420
      IANS=0
      GO TO 2
 500  CALL CLS
      IANS=2
      WRITE(*,'(A)') ' CALCULATING AVERAGE POPULATIONS'
      WRITE(*,'(A)') ' *******************************'
      RETURN
 420  CALL CLS
      RETURN
      END
C
C     *********************** SUBROUTINE CMATEIG **********************
C
      SUBROUTINE CMATEIG(SPU,SV,SE)
      COMPLEX SPU(48,48),SV(48,48),SE(48)
      REAL WK(4800)
      N=48
      IA=48
      IZ=48
      IJOB=2
      CALL EIGCC (SPU,N,IA,IJOB,SE,SV,IZ,WK,IER)
      WRITE(*,5) WK(1)
      WRITE(6,5) WK(1)
   5  FORMAT(' Performance index of the eig.sys. analysis:',F10.5/)
      RETURN
      END
C
C     ********************* SUBROUTINE CMATINV ************************
C
      SUBROUTINE CMATINV(SV,ISV)
      COMPLEX SV(48,48),ISV(48,48)
      REAL A(96,96),B(96,48),WKAREA(9600)
      M=48
      N=96
      IA=96
      IDGT=0
      DO 5 I=1,48
      DO 5 J=1,48
      A(I,J)=REAL(SV(I,J))
   5  A(I+48,J+48)=A(I,J)
      DO 10 I=1,48
      DO 10 J=1,48
      A(I+48,J)=AIMAG(SV(I,J))
  10  A(I,J+48)=-A(I+48,J)
      DO 15 I=1,96
      DO 15 J=1,48
  15  B(I,J)=0.0
      DO 20 I=1,48
  20  B(I,I)=1.0
      CALL LEQT2F (A,M,N,IA,B,IDGT,WKAREA,IER)
      DO 25 I=1,48
      DO 25 J=1,48
  25  ISV(I,J)=CMPLX(B(I,J),B(I+48,J))
      RETURN
      END
C
C     ******************** SUBROUTINE SPUT *************************
C
      SUBROUTINE SPUT(SS,NCHAN,OSPFN,STIT)
      DIMENSION SS(256)
      CHARACTER*12 OSPFN
      CHARACTER*72 STIT
C
C     spectrum output to the unformatted RELAX6.UNF file
C     UNIT3 was opened at the begining of the main program
C
      WRITE(3) NCHAN,STIT
      WRITE(3) (SS(I),I=1,NCHAN)
      CLOSE(3,STATUS='KEEP')
      WRITE(*,641)
      WRITE(6,641)
 641  FORMAT(/' Unformatted file of RELAX6.UNF was created'/)
C
C     spectrum output to a formatted file
C
      OPEN(9,FILE=OSPFN,STATUS='NEW',FORM='FORMATTED')
      WRITE(9,20) STIT
  20  FORMAT(A72)
      WRITE(9,30) (SS(I),I=1,NCHAN)
  30  FORMAT(F12.0)
      CLOSE(9,STATUS='KEEP')
      WRITE(*,642) OSPFN
      WRITE(6,642) OSPFN
 642  FORMAT(' The result spectrum was written to file of: ',A12/)
      RETURN
      END
C
C     ************************ SUBROUTINE CLS *************************
C
      SUBROUTINE CLS
      CHARACTER*1 ESC
      ESC=CHAR(27)
      WRITE(*,1)ESC
   1  FORMAT(1X,A1,'[2J')
      RETURN
      END
