Initial commit

gen/fit_cor.f

@@ -0,0 +1,54 @@
+        subroutine FIT_COR(K,K1,FAC,OFF)
+C	--------------------------------
+
+	include 'fit.inc'
+
+	integer k,k1
+	real fac, off
+
+	integer j
+
+	if (ififu .eq. 6) then
+	  write(isyswr,*) 'Strange: correlation not possible'
+	  return
+	endif
+
+	if (k.gt.nu .or. k.le.0) then
+	  write(isyswr,'(4x,a,i3)') 'Illegal parameter no.:',k
+	endif
+	if (k1.gt.nu .or. k1.le.0) then
+	  write(isyswr,'(4x,a,i3)') 'Illegal parameter no.:',k1
+	  return
+	endif
+	if (k.gt.nu .or. k.le.0) return
+
+	if (icsw(k) .lt. 0 .or. icsw(k) .gt. 0 .and. icto(k) .ne. k1) then
+          write (isyswr,'(4x,3a)')
+	1        pnam(k),' already correlated to ',pnam(icto(k))
+          return
+	endif
+
+	j=k1
+	do while (icsw(j) .ne. 0)
+	  if (j .eq. k) goto 9
+	  j=icto(j)
+	enddo
+9	if (j .eq. k) then
+	  write(isyswr,*) 'recursive correlation not allowed'
+	  return
+	endif
+
+	if (lcode(k) .gt. 0) lcode(k)=-lcode(k)
+	icsw(k)=1
+	icto(k)=k1
+	cfac(k)=fac
+	coff(k)=off
+	if (off .eq. 0) then
+          write (isyswr,'(/4x,5a,f7.3)')
+	1  'Correlation: ',pnam(k),' = ',pnam(k1),' *',fac
+	else
+          write (isyswr,'(/4x,5a,f7.3,a,g12.5)')
+	1  'Correlation: ',pnam(k),' = ',pnam(k1),' *',fac,' +',off
+	endif
+	call extoin
+	end