PROGRAM GJJCONF
      implicit integer*4 (i-n)
      implicit real*8 (a-h,o-z)
      parameter (NTY0=100,nat0=100)
      DIMENSION NG(2,NTY0),NA(2,NTY0,10),ash(NTY0),
     1ncf(NTY0),ajm(nat0,nat0)
      CHARACTER*160 ff
      CHARACTER*4 s4
      CHARACTER*16 lb(NTY0)
      CHARACTER*80 fn
c
c     extract gaussian nmr data - COUPLINGS
c     NCO number of conformations/molecules
c     NTY number of COUPLINGS to be extracted, each can include more
c         chemically equivalent atoms
c    site 1                      site 2
c    atoms 1..NG(1               1..NG(2
c          NA(1 ...NA(NG(1       NA(2 ...NA(NG(2
c
c     ncf  .. number of found couplings, should be NG(1 x NG(2 if non-redundant

      nsat=0
      open(2,file='GNMR.OPT')
1     read(2,200,end=999,err=999)s4
200   format(a4)
      if(s4(1:3).eq.'NCO')read(2,*)NCO
      if(s4(1:3).eq.'NTY')then
       read(2,*)NTY
       if(NTY.gt.NTY0)call report('Too many shifts.')
       do 3 i=1,NTY
       read(2,2001)lb(i)
       write(6,2001)lb(i)
2001   format(a16)
c      number of same atoms, their list, for the two coupled moments
       read(2,*)NG(1,i),(NA(1,i,j),j=1,NG(1,i))
3      read(2,*)NG(2,i),(NA(2,i,j),j=1,NG(2,i))
      endif
      goto 1
999   close(2)

      icc=0
      open(3,file='NAMES.LST')
      open(8,file='JJ.TAB')
      write(8,8002)(lb(i),i=1,NTY)
8002  format(4x,1000(a16))
      do 2 ic=1,NCO
      read(3,3000)fn
3000  format(a80)
      write(6,3000)fn
      open(2,file=fn)
      IR=0
5     READ(2,2002,END=1000,err=1000)ff
2002  FORMAT(A160)
      if(ff(2:28).eq.'CP coupling constants in SI')IR=0
      if(ff(2:28).eq.'CP coupling constants in Hz')IR=1
c
c     sychrovsky format
      IF(ff(1:2).EQ.' ('.and.ff(8:8).eq.','.and.ff(14:16).eq.')  '.and.
     1 IR.eq.1)then
       icc=icc+1
       do 4 is=1,NTY
       ncf(is)=0
4      ash(is)=0.0d0
       open(22,file='scr')
       write(22,*)ff(5:7)//ff(11:13)//ff(15:120)
       rewind 22
       read(22,*)j1,j2,dso,pso,fc,sd,tot
       close(22)
       do 6 is=1,NTY
c
c      does it belong to the coupling is:
       ibl=0
       do 61 ii=1,NG(1,is)
61     if(NA(1,is,ii).eq.j1)ibl=ibl+1
       ibr=0
       do 62 ii=1,NG(2,is)
62     if(NA(2,is,ii).eq.j2)ibr=ibr+1
       if(ibl.eq.1.and.ibr.eq.1)then
        ncf(is)=ncf(is)+1
        ash(is)=ash(is)+tot
       endif
c
c      does it belong to the coupling is (reversed order):
       ibl=0
       do 63 ii=1,NG(1,is)
63     if(NA(1,is,ii).eq.j2)ibl=ibl+1
       ibr=0
       do 64 ii=1,NG(2,is)
64     if(NA(2,is,ii).eq.j1)ibr=ibr+1
       if(ibl.eq.1.and.ibr.eq.1)then
        ncf(is)=ncf(is)+1
        ash(is)=ash(is)+tot
       endif
6      continue
       do 71 is=1,NTY
71     if(ncf(is).gt.0)ash(is)=ash(is)/dble(ncf(is))
       write(8,8000)icc,(ash(i),i=1,NTY)
      ENDIF
c
c     nesychrovsky format
      IF(ff(2:41).EQ.'Total nuclear spin-spin coupling J (Hz):')then
       icc=icc+1
       do 41 is=1,NTY
       ncf(is)=0
41     ash(is)=0.0d0
       if(nsat.eq.0)then
        write(6,*)'nat:'
        read(5,*)N
        nsat=N
       else	
        N=nsat
       endif	
       if(N.gt.nat0)then
        write(6,*)'too many atoms'
	stop
       endif

       N1=1
111    N3=N1+4
       IF(N3.GT.N)N3=N
       read(2,*)
       DO 130 LN=N1,N
130    READ(2,*)idum,(ajm(LN,J),J=N1,MIN(LN,N3))
       N1=N1+5
       IF(N3.LT.N)GOTO 111
       DO 31 I=1,N
       DO 31 J=I,N
   31  ajm(I,J)=ajm(J,I)

       do 1001 j1=1,N
       do 1001 j2=j1,N
       tot=ajm(j1,j2)
       do 601 is=1,NTY
c
c      does it belong to the coupling is:
       ibl=0
       do 6101 ii=1,NG(1,is)
6101   if(NA(1,is,ii).eq.j1)ibl=ibl+1
       ibr=0
       do 6201 ii=1,NG(2,is)
6201   if(NA(2,is,ii).eq.j2)ibr=ibr+1
       if(ibl.eq.1.and.ibr.eq.1)then
        ncf(is)=ncf(is)+1
        ash(is)=ash(is)+tot
       endif
c
c      does it belong to the coupling is (reversed order):
       ibl=0
       do 6301 ii=1,NG(1,is)
6301   if(NA(1,is,ii).eq.j2)ibl=ibl+1
       ibr=0
       do 6401 ii=1,NG(2,is)
6401   if(NA(2,is,ii).eq.j1)ibr=ibr+1
       if(ibl.eq.1.and.ibr.eq.1)then
        ncf(is)=ncf(is)+1
        ash(is)=ash(is)+tot
       endif
601    continue
1001   continue
       do 7 is=1,NTY
7      if(ncf(is).gt.0)ash(is)=ash(is)/dble(ncf(is))
       write(8,8000)icc,(ash(i),i=1,NTY)
8000   format(i4,1000f16.2)
      ENDIF

      GOTO 5
1000  CLOSE(2)

2     continue
      close(3)
      close(8)
      open(8,file='transpose.tab')
      do i=1,NTY
       write(8,80000)i,lb(i),ash(i)
80000  format(i4,a16,f16.2)
      enddo
      close(8)
      STOP
      END

      subroutine report(s)
      character*(*) s
      write(6,*)s
      stop
      end