C\begin{verbatim}
c       program NSGA-II-aJG.f
      program sga
c     **************************************************
c     *                                                *
c     *             Biogenetic-NON-DOMINATED SORTING              *
c     *               GENETIC ALGORITHM-II-aJG               *
c     *                    (B-NSGA-II-aJG)                      *
c     **************************************************
c NSGA-II as developed by Kalyanmoy Deb, Indian Institute of Technology, Kanpur
c (The simple GA is adapted in Fortran from David E. Goldberg's Pascal
c  code.The NSGA-II code is adapted in Fortran from Kalyanmoy Deb's C code by
c  Rahul Kasat). The present version of B-NSGA-II-aJG has been developed by Manojkumar Ramteke, a Post graduate student of Dr. S K Gupta, ChE Dept, 
c  IIT Kanpur, India 
c  All rights reserved. This listing is for personal use.
c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
c This routine finds the optimum point of a constrained
c optimization problem using genetic algorithms.
c Code your function in subroutine 'funct'. Presently, this subroutine has the ZDT4 Problem
c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
C     ____________________________________________________________________
      Integer oldchr1(200,1000), newchrom(200,1000),oldrank(200)
      Integer  chr(1000),lsubstr(50),dummychr(1000),oldrankno(200)
c      integer newrankar(200,200),newmaxrank,newrankno(200),newrank(200)
      integer oldrankar(200,200),keepchrom(200,1000),globchrom(400,1000)
      integer oldmaxrank,grank(400),grankno(400),maxgen,igen
      integer lchrom,ipopsize,nmute,ncross,nparam
C     ____________________________________________________________________
      double precision  oldx(200,50),factor(50),oldcub_len(200)
      double precision dummyx(50),alow(50),ahigh(50),newx(200,50)
      double precision oldfit1(200),oldfit2(200),newfit1(200)
      double precision  newfit2(200),keepx(200,50),globfit2(400)
      double precision keepfit1(200),keepfit2(200),gcub_len(400)
	double precision globx(400,50),a11(200),globfit1(400),a22(200)
	double precision nd1(100),nd2(100), sd, error 
	real pjump, pcross, pmute

c............. common blocks .........................
c.....for GA parameters
      common/sgaparam/ipopsize,lchrom,maxgen,ncross,
     -         nmute,pcross,pmute,nparam,pjump

c.....for random variables routines
      common/randvar/oldrand,jrand

c.....for other constant
      common/consts/fix
c........ fixed array for random number generator .....
      real oldrand(55), fix
      integer jrand
c........ read all GA input parameters first ..........

       call initdata

c     -------------------------------------------------------
c............. main program begins here ................

      igen = 0
      do i = 1,ipopsize
       do j =1,lchrom
        oldchr1(i,j)=0
       end do
       do j=1,nparam
        oldx(i,j)=0.0
       end do
        oldfit1(i)=0.0
        oldfit2(i)=0.0
      end do



c.....create initial population and evaluate*********
      call initialize(oldchr1,oldx,oldfit1,oldfit2,factor,lsubstr,
     1  alow,ahigh,dummyx,dummychr,oldrank,oldcub_len,oldmaxrank,
     1  oldrankar,oldrankno)

      do i=1,ipopsize
         oldcub_len(i)=0.0
      end do

c.....main generation loop begins   =====
10    igen = igen + 1
c.....perform one generation of GA operators ====
c       contains reproduction, crossover and mutation
	oldmaxrank=0
      do i=1,ipopsize
       oldrankno(i)=0
       oldrank(i)=0
       do j=1,ipopsize
        oldrankar(i,j)=0
       end do
      end do

	call initranking(oldfit1,oldfit2,oldrank,oldrankno,oldmaxrank,
     -      oldrankar)

      write(*,*)'oldmaxrank=',oldmaxrank

      do i=1,ipopsize
         oldcub_len(i)=0.0
      end do

	do i=1,oldmaxrank
        call share1(i,oldfit1,oldfit2,oldrankno,oldrankar,oldrank,
     1              oldcub_len)
      end do

	
      do i = 1,ipopsize
       do j =1,lchrom
        newchrom(i,j)=0
       end do
       do j=1,nparam
        newx(i,j)=0.0
       end do
        newfit1(i)=0.0
        newfit2(i)=0.0
      end do

      call generation(oldchr1,newchrom,newx,oldx,oldfit1,oldfit2,newfit1
     1 ,newfit2,factor,lsubstr,alow,ahigh,chr,oldrank,oldcub_len,
     1   oldrankar,igen)


c****here we make global population by mixing parents and children******

      do i = 1,2*ipopsize
       do j =1,lchrom
        globchrom(i,j)=0
       end do
       do j=1,nparam
        globx(i,j)=0.0
       end do
        globfit1(i)=0.0
        globfit2(i)=0.0
      end do



      call global(oldchr1,newchrom,oldx,newx,oldfit1,newfit1,oldfit2,
     1  newfit2,globchrom,globx,globfit1,globfit2)

c****here we carry out ranking , sharing and making of pseudo parents ***
c*****which can be used in next generation *************
      call keepalive(globx,globchrom,globfit1,globfit2,keepx,keepchrom,
     1  keepfit1,keepfit2,grank,grankno,gcub_len,oldrank,oldcub_len)

       do i = 1, ipopsize
         a11(i) = 0
         a22(i) = 0
       end do

c*****here we make pseudo parents for the next generation********
       do i=1,ipopsize
          oldfit1(i)=keepfit1(i)
          oldfit2(i)=keepfit2(i)
          a11(i)= (1/oldfit1(i)) - 1.0
          a22(i)= (1/oldfit2(i)) - 1.0

          do j=1,nparam
           oldx(i,j)= keepx(i,j)
          end do
          do j=1,lchrom
            oldchr1(i,j)= keepchrom(i,j)
c	      write(*,*)'vvvv',oldchr1(i,j)
          end do
c	pause
       end do
		
	open(unit= 111, file='res2.txt')
	write(*,*)'gen=',igen
	write(111,*)'gen=',igen 
       do i=1,ipopsize
        write(*,*) i,a11(i),a22(i)
c	end do
	
c	if(igen.eq.100)then
c	do i=1,ipopsize
        write(111,143)i,oldx(i,1),oldx(i,2),oldx(i,3),oldx(i,4),
	& oldx(i,5),oldx(i,6),oldx(i,7),oldx(i,8),oldx(i,9),oldx(i,10),
	&a11(i),a22(i)

143	  format(1X,I3,1X,12f10.5)
	 end do	

	open(unit = 11,file = 'cover0.txt')
	do i = 1,ipopsize
	read(11,*) nd1(i),nd2(i)
	enddo
	close(11)

	if(igen. gt.1)then
	sd=0
	do i =1,ipopsize
	do j =1,ipopsize

	if(nd1(j-1). lt. a11(i). and. nd1(j). gt. a11(i))then 
	nd2(i)=nd2(j-1) + 	
	&(nd2(j)-nd2(j-1))/(nd1(j)-nd1(j-1))*(a11(i)-nd1(j-1))
	endif
	enddo
 	sd = sd + (a22(i)-nd2(i))**2
	
	enddo

	
	
     	error = sd/ipopsize				
	open(unit= 16, file='res1.txt')
	s = nint(100*random())
c	write (*,*) s
c	pause

	if(igen. le. 200. and.((igen/2)*2-igen). eq. 0)then	
	write(16,144)igen/2, oldx(s,1),oldx(s,2),oldx(s,3),oldx(s,4),
	& oldx(s,5),oldx(s,6),oldx(s,7),oldx(s,8),oldx(s,9),oldx(s,10),
	&a11(s),a22(s)

144   format(1X,I3,1X,12f20.10)
	endif
	endif




c	end if 
c     pause    
c*******condition to go to next loop********
       if(igen .lt. maxgen) goto 10
	close(111)
	close (16)
c	pause

	

      stop
      end


c******************all the subroutines atart here*******************************
c     *****   initializes GA parameters  *****
c**********input all ur data here***********
      subroutine initdata
      common/sgaparam/ipopsize,lchrom,maxgen,ncross,
     -         nmute,pcross,pmute,nparam,pjump
      write(*,*)'  '
      write(*,*)'            Non-dominated SortingII'
      write(*,*)'         Genetic Algorithms in FORTRAN'
      write(*,*)'                 Kalyanmoy Deb'
      write(*,*)'                      &   '
      write(*,*)'                 Rahul Kasat'
      write(*,*)'              All rights reserved'
      write(*,*)'  '
c.....read all GA parameters
      write(*,*)'** GA data entry and initialization **'
      nparam=10
      write(*,*) 'nparam -------> ',nparam
c      read(*,*) nparam
      lchrom=300
      write(*,*) 'lchrom --------> ',lchrom
      ipopsize= 100
      write(*,*) 'ipopsize ------------> ',ipopsize
c      read(*,*) ipopsize
      maxgen= 1000
      write(*,*) 'maxgen ------------>',maxgen
c      read(*,*) maxgen
      pcross=0.9
      write(*,*) 'pcross-------->',pcross
c      read(*,*) pcross
c	lchrom = 900
c	lchrom = 300.0
      pmute=1.0/lchrom
      write(*,*) 'pmute -------> ',pmute

c      read(*,*) pmute
	pjump = 0.6
	write(*,*)'pjump--------> ', pjump
	nmute = 0
      ncross = 0
c	pause
      return
      end


c     ***** initializes the data, population and
C           statistics variables                  ****
      subroutine initialize(oldchr1,oldx,oldfit1,oldfit2,factor,
     - lsubstr,alow,ahigh,dummyx,dummychr,oldrank,oldcub_len,
     - oldmaxrank,oldrankar,oldrankno)
      common/sgaparam/ipopsize,lchrom,maxgen,ncross,
     -         nmute,pcross,pmute,nparam,pjump
      common/consts/fix
      integer oldchr1(200,1000),oldrank(200),oldmaxrank
      integer dummychr(1000),oldrankar(200,200)
      double precision oldx(200,50),oldcub_len(200)
      double precision oldfit1(200),oldfit2(200)
      double precision factor(nparam), dummyx(nparam)
      double precision alow(nparam), ahigh(nparam)
      integer lsubstr(nparam),oldrankno(200)


c   *****enter the string coding information**********
c   *****change 'i' to number and enter for nparam parameters separately*****
c   *****enter the length of substring for each variable*******
      
	lsubstr(1)= 30

c   ******enter alow and ahigh here*********
      alow(1)= 0.0
      ahigh(1)= 1.0


c     *******calculate factor here*********
      factor(1) = 2.0**float(lsubstr(1))-1.0

	do i = 2,10
	lsubstr(i)= 30
	alow(i)= -10.0
      ahigh(i)= 10.0
	factor(i) = 2.0**float(lsubstr(i))-1.0
	end do





c     ******enter total length of the chromosome******
c      lchrom=32

c    *****INITIALIZE THE RANDOM NUMBER GENERATOR************
      call randomize

c    *****CREATE THE INITIAL POPULATION**********
      call initpop(oldchr1,oldx,oldfit1,oldfit2,dummyx,dummychr,
     -         lsubstr,alow,ahigh,factor)

      oldmaxrank=0
      do i=1,ipopsize
       oldrankno(i)=0
       oldrank(i)=0
c       oldcub_len(i)=0.0
       do j=1,ipopsize
        oldrankar(i,j)=0
       end do
      end do

c    *******doing the ranking in the initial population**********
      call initranking(oldfit1,oldfit2,oldrank,oldrankno,oldmaxrank,
     -      oldrankar)

       write(*,*)'oldmaxrank=',oldmaxrank

      do i=1,ipopsize
         oldcub_len(i)=0.0
      end do

c    ********doing the sharing for the diversity******************
      do i=1,oldmaxrank
        call share1(i,oldfit1,oldfit2,oldrankno,oldrankar,oldrank,
     1              oldcub_len)
      end do


c  *****report the initial population ************************
      call initreport
c      write(*,*)'************************************************'
      write(*,*)'printing the information of initial parent population'
      write(*,*)'VALUES OF THE DIFFERENT PARAMETERS'
      write(*,*)'POPULATION NO. , X1 , X2..'
       do i = 1, ipopsize
         write(*,*) i,oldx(i,1)
       end do
c	pause
      write(*,*)'***************************************************'
      return
      end


c ************subroutines needed for the random number generator*********************
c.............. utility subroutines ...................
c     *****   function to find i mod j *****
      function modop(i,j)
      modop = i - j*ifix(float(i)/float(j))
      return
      end

c     *** random number initialization routines ***
      subroutine advance_random
      common /randvar/ oldrand,jrand
      real oldrand(55)
      do 11 j1 = 1,24
         rand_new = oldrand(j1) - oldrand(j1+31)
         if(rand_new.lt.0.0) rand_new = rand_new + 1.0
         oldrand(j1) = rand_new
 11   continue
      do 12 j1 = 25,55
         rand_new = oldrand(j1)-oldrand(j1-24)
         if(rand_new.lt.0.0)  rand_new = rand_new+1.0
         oldrand(j1) = rand_new
 12   continue
      return
      end

      subroutine warmup_random(random_seed)
      real oldrand(55)
      common/randvar/oldrand,jrand
      oldrand(55) = random_seed
      rand_new = 1.0e-9
      prev_rand = random_seed
      do 21 j1 = 1,54
         ii = modop(21*j1,55)
         oldrand(ii) = rand_new
         rand_new = prev_rand - rand_new
         if(rand_new.lt.0.0) rand_new = rand_new + 1.0
         prev_rand = oldrand(ii)
 21   continue
      call advance_random
      call advance_random
      call advance_random
      jrand = 0
      return
      end

c     ***** create a random number between 0 and 1 *****
      function random()
      real oldrand(55)
      common/randvar/oldrand,jrand
      jrand = jrand + 1
      if(jrand.gt.55) then
         jrand = 1
         call advance_random
      endif
      random = oldrand(jrand)
      return
      end

c     ***** flip a coin with a probability prob *****
      function iflip(prob)
      iflip = 0
      if ((prob.eq.1.0).or.(random().le.prob)) iflip = 1
      return
      end

c     * create a random integer between ilow and ihigh *
      function irnd(ilow,ihigh)
      if(ilow.ge.ihigh) then
         i = ilow
      else
         i = ifix(random()*(ihigh-ilow+1)+ilow)
         if(i.gt.ihigh) i = ihigh
      endif
      irnd = i
      return
      end

c     ***** initiate the random number generator *****
      subroutine randomize
      common/consts/fix
      randomseed=0.88876
 61   write(*,*)'enter seed random number (0.0 to 1.0)>',randomseed
c      read(*,*) randomseed
      if ((randomseed.lt.0) .or. (randomseed.gt.1.0))
     -   go to 61
      call warmup_random(randomseed)
      fix = randomseed
      return
      end
c\end{verbatim}


c   ***************subroutines used in the initpop***********
c.....*****  generates initial random population  *****
      subroutine initpop(oldchr1,oldx,fitness1,fitness2,x,chr,
     -         lsubstr,alow,ahigh,factor)
      common/sgaparam/ipopsize,lchrom,maxgen,ncross,
     -         nmute,pcross,pmute,nparam,pjump

      integer oldchr1(200,1000), chr(lchrom),chr1(lchrom)
      double precision oldx(200,50), fitness1(200),fitness2(200)
	double precision oldx1(200,50),unx(200,nparam)
      double precision alow(nparam), ahigh(nparam), factor(nparam)
      integer lsubstr(nparam),bairs
      double precision x(nparam)

	open(unit= 16, file='res1.txt')
	  
	  do i = 1,100
       read(16,*)i,oldx1(i,1),oldx1(i,2),oldx1(i,3),oldx1(i,4),
	& oldx1(i,5),oldx1(i,6),oldx1(i,7),oldx1(i,8),oldx1(i,9),
     & oldx1(i,10)	 
c	 write(*,*)i,oldx1(i,1),oldx1(i,2),oldx1(i,3),oldx1(i,4),
c	& oldx1(i,5),oldx1(i,6),oldx1(i,7),oldx1(i,8),oldx1(i,9),
c     & oldx1(i,10)
c	pause


	 enddo




	! PUT bairs = 1 FOR APPLYING BIOGENETIC NSGA-II-aJG, modify the file res1.txt
	!WITHOUT BIOGENETIC LAW, USE bairs =0



      do 121 j = 1,ipopsize
	bairs =1				


	do 999 k=1, lchrom

      chr1(k) = 0

999	continue





      do 132 i = 1,nparam

	if(oldx1(j,i). lt.alow(i)) then
	oldx1(j,i)= alow(i)
	endif

	if(oldx1(j,i). gt.ahigh(i)) then
	oldx1(j,i)= ahigh(i)
	endif

      unx(j,i) = (oldx1(j,i)-alow(i))/(ahigh(i)-alow(i))*factor(i)
	

	j1=(i-1)*30.0	
 888 	j1=j1+1

	if((int(unx(j,i)/2)*2-unx(j,i)).eq.0) then
	chr1(j1)=0

	else
	chr1(j1)=1
	endif
	unx = int(unx(j,i)/2)
	if(unx(j,i). ge. 1. or. j1.lt.30) then
	goto 888
	endif

c	write(*,*)j1
c	pause
	
 

	do 777 k=1,lchrom

      chr(k)= chr1(k)
		
777	continue
	      	 
 132  continue

c	write (*,*) chr
c	pause

           do 188 j1 = 1,lchrom
c  *******create random strings of 1 and 0********

          
            oldchr1(j,j1)= chr(j1)
c            write(*,*)'j j1 chrom',j,j1,oldchr1(j,j1)

c		write (*,*) oldchr1(j,j1)
c		pause 
 188     continue



	if(bairs. eq. 0) then
	
           do 122 j1 = 1,lchrom
c  *******create random strings of 1 and 0********
            chr(j1) = iflip(0.5)
            oldchr1(j,j1) = chr(j1)
c            write(*,*)'j j1 chrom',j,j1,oldchr1(j,j1)




 122     continue
     	   endif

 


c  *******calculate x values from the string*******
         call decodevars(chr,x,lsubstr,alow,ahigh,
     -           factor)
         do 123 j1 = 1,nparam
            oldx(j,j1) = x(j1)
c          write(*,*)' X = ',oldx(j,j1), oldx1(j,j1)
c	pause
 123     continue


c  ****** calculate the fitness of the string***********
         fitness1(j) = funct1(x)
         fitness2(j) = funct2(x)
c        write(*,*) 'fit1=  ,fit2=',oldx(j,1),oldx(j,2),oldx(j,3),
c	&  oldx(j,4),oldx(j,5),oldx(j,6),oldx(j,7),oldx(j,8),oldx(j,9),
c     &  oldx(j,10),((1/fitness1(j)) - 1.0),((1/fitness2(j)) - 1.0)


c	pause

 121  continue
      return
      end

c   ********decodvars**************************************
c     *****  decodes a substring of length lstr *****
      function decode(chrom,id,lstr)
      common/sgaparam/ipopsize,lchrom,maxgen,ncross,
     -         nmute,pcross,pmute,nparam,pjump
      integer chrom(lchrom)
      acc = 0.0
c.....multiplier is one for the first bit position
      powof2 = 1.0
      do 71 j = 1,lstr
c....... accumulate the bit value times the multiplier
         if(chrom(id+j) .eq. 1) acc = acc + powof2
c....... update multiplier for next bit position
         powof2 = powof2 * 2
 71   continue
      decode = acc
c      write(*,*)'decode=',decode
c      pause
      return
      end

c     * map the decoded value in the specified region *
      function xmap(y,alo,ahi,denom)
	double precision alo, ahi,denom
c.....linear mapping
      xmap = alo + (ahi-alo)*y/denom
c      write(*,*)alo,ahi,y,denom,xmap
c      write(*,*)'xmap=',xmap
c      pause
      return
      end

c     ** calculate the parameter value from a string **
      subroutine decodevars(chrom,x,lsubstr,alow,ahigh,
     -         factor)
      common/sgaparam/ipopsize,lchrom,maxgen,ncross,
     -         nmute,pcross,pmute,nparam,pjump
      integer chrom(1000)
      integer lsubstr(50)
      double precision alow(50),ahigh(50),factor(50)
      double precision x(50)
      jpos = 0
      do 10 j = 1,nparam
c.......get the decoded value of the substring
        y = decode(chrom,jpos,lsubstr(j))	

c...... map in the specified range for real value
        x(j) = xmap(y,alow(j),ahigh(j),factor(j))
c...... bit position for the next variable in the string
        jpos = jpos + lsubstr(j)
c	write(*,*)'x=',x(j),j
  10  continue
      return
      end

c*************subroutines for the ranking of initial population**********************

      subroutine initranking(ifit1,ifit2,irank,irankno,
     1           imaxrank,irankar)

      common/sgaparam/ipopsize,lchrom,maxgen,ncross,nmute,pcross,
     1                pmute,nparam,pjump

      double precision ifit1(200),ifit2(200)
      integer irank(200),irankno(200),maxrank1,nondom
      integer irankar(200,200),iflag(200)
      integer imaxrank,rnk,q,i,j,k,val

        imaxrank=0
      do i = 1, ipopsize
         irank(i)=0
         irankno(i)=0
         iflag(i)=2
      end do
      do i=1,ipopsize
        do  j=1,ipopsize
             irankar(i,j)=0
        end do
      end do

      rnk=0
      nondom=0
      maxrank1=0

      do k=1,ipopsize
         q=1
         do j=1,ipopsize
            if(iflag(j).ne.1) goto 1001
            if(j.eq.ipopsize) goto 1002
         end do


1001         rnk = rnk+1

          do j=1,ipopsize
            if(iflag(j).eq.0) iflag(j)=2
          end do

          do i=1,ipopsize
            if(iflag(i).ne.1 .and. iflag(i).ne.0) then
             do j=1,ipopsize
               if(i.ne.j) then
                 if(iflag(j).ne.1) then
                   val= value(ifit1(i),ifit1(j),ifit2(i),
     1                 ifit2(j))
                   if (val.eq.2) then
                      iflag(i)=0
                      goto 1003
                   end if

                   if (val.eq.1) iflag(j)=0
                   if (val.eq.3) then
                     nondom = nondom+1
                     if(iflag(j).ne.0) iflag(j)=3
                   end if
                 end if
               end if
              if(j .eq. ipopsize) then
                irank(i)=rnk
                iflag(i)=1
c                write(*,*)'i=',i
                irankar(rnk,q)=i
c                write(*,*)'irankar=',irankar(rnk,q)
                q = q+1
              end if
             end do
            end if
1003      end do


          irankno(rnk)=q-1
      end do

1002      maxrank1=rnk

      imaxrank = maxrank1
      return
      end

c*********function indcmp*used in initranking********************

      function value(oldfit11,oldfit12,oldfit21,oldfit22)
      common/sgaparam/ipopsize,lchrom,maxgen,ncross,nmute,pcross,
     1                pmute,nparam,pjump

      double precision  oldfit11,oldfit12,oldfit21,oldfit22


      if(((oldfit11 .ge. oldfit12) .and.((oldfit21 - oldfit22) .gt.
     1     1e-7)) .or.(((oldfit11 - oldfit12) .gt.1e-7) .and.
     1  (oldfit21.ge.oldfit22))) then
             value = 1
      else if(((oldfit11 .le. oldfit12).and.((oldfit22 - oldfit21).gt.
     1           1e-7)) .or.(((oldfit12 - oldfit11) .gt.1e-7) .and.
     1           (oldfit22 .ge. oldfit21))) then
             value=2
           else
             value=3
      end if

      return
      end

c******subroutine for sharing for initial population*************
      subroutine share1(rnk,sfit1,sfit2,srankno,srankar,srank,
     1           scub_len)

      common/sgaparam/ipopsize,lchrom,maxgen,ncross,
     -         nmute,pcross,pmute,nparam,pjump

      double precision sfit1(200),sfit2(200),scub_len(200)
      double precision fpara(200,3),length(200,3),max
      integer rnk,srankno(200),srankar(200,200)
      integer srank(200),i,m1,a

      m1 = srankno(rnk)
c      write(*,*)'m1=',m1

      do i=1,m1
          fpara(i,1)=0.0
          fpara(i,2)=0.0
          length(i,1)=0.0
          length(i,2)=0.0
      end do

      do i=1,m1
         a= srankar(rnk,i)
         fpara(i,1)=real(a)
         fpara(i,2)=sfit1(a)
      end do

      call sort(m1,fpara)
      max = fpara(m1,2)

      do i=1,m1
        if(i.eq.1 .or. i.eq.m1)then
          length(i,1)=fpara(i,1)
          length(i,2)=100*max
        else
          length(i,1)=fpara(i,1)
          length(i,2)=abs(fpara(i+1,2)-fpara(i-1,2))
        end if
      end do

      do i=1,m1
       a=length(i,1)
       scub_len(a)=scub_len(a)+length(i,2)
      end do

      do i=1,m1
          fpara(i,1)=0
          fpara(i,2)=0
          length(i,1)=0
          length(i,2)=0
      end do

      do i=1,m1
         a= srankar(rnk,i)
         fpara(i,1)=real(a)
         fpara(i,2)=sfit2(a)
c         write(*,*)i,fpara(i,1),fpara(i,2)
      end do

      call sort(m1,fpara)
      max = fpara(m1,2)

      do i=1,m1
        if(i.eq.1 .or. i.eq.m1)then
          length(i,1)=fpara(i,1)
          length(i,2)=100*max
        else
          length(i,1)=fpara(i,1)
          length(i,2)=abs(fpara(i+1,2)-fpara(i-1,2))
        end if
      end do

      do i=1,m1
       a=length(i,1)
       scub_len(a)=scub_len(a)+length(i,2)
c       write(*,*) a,oldcub_len(a)
      end do

      return
      end

c*********function sotr is used in sharing*************
      subroutine sort(m1,fpara)

      common/sgaparam/ipopsize,lchrom,maxgen,ncross,
     -         nmute,pcross,pmute,nparam,pjump

      integer m1,i1,k1
      double precision temp,temp1,fpara(200,3)

      do k1=1,m1-1
        do i1=k1+1,m1
          if(fpara(k1,2) .gt. fpara(i1,2))then
             temp=fpara(k1,2)
             temp1=fpara(k1,1)
             fpara(k1,2)=fpara(i1,2)
             fpara(k1,1)=fpara(i1,1)
             fpara(i1,2)=temp
             fpara(i1,1)=temp1
          end if
        end do
      end do
      return
      end


c*****************put ur 1st objective function here********
c     ***** objective function for optimization  *****
      function funct1(x)
      common/sgaparam/ipopsize,lchrom,maxgen,ncross,
     -                nmute,pcross,pmute,nparam,pjump
      double precision x(nparam)

      aobj=x(1)

c.....this transformation is for minimization problems
      funct1 = 1.0/(1.0+aobj)
      return
      end

c     ***** put ur 2nd objective function for optimization here  *****
      function funct2(x)
      common/sgaparam/ipopsize,lchrom,maxgen,ncross,
     -                nmute,pcross,pmute,nparam,pjump
      double precision x(nparam),sum,gx

	sum = 0
      do i = 2, nparam
    	 sum = sum + (x(i)*x(i) - 10.0*cos(12.56*x(i)))
	end do

    	gx = 1.0 + 10*(nparam - 1)+sum

    	aobj = gx*(1.0- sqrt(x(1)/gx))

c.....this transformation is for minimization problems
      funct2 = 1.0/(1.0+aobj)
      return
      end


c*********initial report subroutine***********
c     *****   prints report of initial population  *****
      subroutine initreport
      common/sgaparam/ipopsize,lchrom,maxgen,ncross,
     -         nmute,pcross,pmute,nparam,pjump
      common/statist/igen,avg,amax,amin,sumfitness
      common/consts/fix
      write(*,*)'  '
      write(*,*)'            Non-dominated SortingII'
      write(*,*)'         Genetic Algorithms in FORTRAN'
      write(*,*)'                    by '
      write(*,*)'                 RahulKasat'
      write(*,*)'              All rights reserved'
      write(*,*)'  '
      write(*,*)'                 GA parameters '
      write(*,*)'               ----------------- '
      write(*,*)'  '
c.....print the GA parameters

      write(*,9050) ipopsize
      write(*,9051) lchrom
      write(*,9052) maxgen
      write(*,9053) pcross
      write(*,9054) pmute
      write(*,9055) fix
      write(*,*) '  '

 9050 format(' population size       = ',i4)
 9051 format(' chromosome length     = ',i4)
 9052 format(' max. # of generations = ',i4)
 9053 format(' crossover probability = ',f8.5)
 9054 format(' mutation probabilty   = ',f8.5)
 9055 format(' seed random number    = ',f8.5)

      return
      end



c *******subroutine generation***********
      subroutine generation(oldchr1,newchrom,newx,oldx,oldfit1,oldfit2,
     1   newfit1,newfit2,factor,lsubstr,alow,ahigh,chr,oldrank,
     1   oldcub_len,oldrankar,igen)

      common/sgaparam/ipopsize,lchrom,maxgen,ncross,
     -         nmute,pcross,pmute,nparam,pjump

      integer oldchr1(200,1000),newchrom(200,1000)
      integer chr(1000),lsubstr(50),oldrank(200)
      integer oldrankar(200,200),mate1,mate2
      integer rchr(200,1000),rrank(200)
      integer rrankar(200,200)
      double precision newx(200,50),x(50),oldfit1(200)
      double precision oldfit2(200),newfit1(200),newfit2(200)
      double precision factor(50),alow(50),ahigh(50)
      double precision oldcub_len(200),r,r1,r2
      double precision rx(200,50),rfit1(200),rfit2(200)
      double precision rcub_len(200),oldx(200,50)


c*******tournament selection operator********

      do i = 1,ipopsize
       do j =1,lchrom
        rchr(i,j)=0
       end do
       do j=1,nparam
        rx(i,j)=0.0
       end do
        rfit1(i)=0.0
        rfit2(i)=0.0
        rrank(i)=0
        rcub_len(i)=0.0
      end do


      call nselect(oldchr1,oldfit1,oldfit2,oldrank,oldcub_len,
     1      oldx,rchr,rfit1,rfit2,rrank,rcub_len,rx)

	
      j=1
      k=0
      n=ipopsize
c***** select the mates for the xover and mutation*********
181   r= random()
      r=r*ipopsize
      r1=nint(r)
      if(r1.eq.0) r1=ipopsize-n
      if(r1 .eq.ipopsize) r1=(ipopsize-4)/2
      if(r1.eq.0) r1=ipopsize-n+1
      mate1=r1
c      write(*,*)'mate1',mate1
      if(mate1.eq.0) mate1 = mate1 + 1
      r= random()
      r=r*ipopsize
      r2=nint(r)
       if(r2.eq.0) r2=ipopsize-k
       if(r2 .eq.ipopsize) r2=(ipopsize-2)/2
      if(r2.eq.0) r2=ipopsize-k+1
      mate2=r2
c      write(*,*)'mate2',mate2
      if(mate2.eq.0)mate2=mate2+1
      if (mate1 .eq. mate2) goto 181
c.....perform crossover using the selected mates
      call crossover(j,mate1,mate2,rchr,newchrom)
c.....compute real values of the first child string
      do 20 j1 = 1,lchrom
         chr(j1) = newchrom(j,j1)
c         write(*,*)'j,j1,new1',j,j1,newchrom(j,j1)
 20   continue
      call decodevars(chr,x,lsubstr,alow,ahigh,factor)
      do 10 j1 = 1,nparam
         newx(j,j1) = x(j1)
c         write(*,*)'j , j1,newx',j,j1,newx(j,j1)
 10   continue
c.....compute fitness of the first child string
      newfit1(j) = funct1(x)
      newfit2(j) = funct2(x)
c      newfit(j)=newfit1(j)
c.....compute real values of the second child string
      do 22 j1 = 1,lchrom
         chr(j1) = newchrom(j+1,j1)
c         write(*,*)'j,j1,new2',j+1,j1,newchrom(j+1,j1)
 22   continue
      call decodevars(chr,x,lsubstr,alow,ahigh,factor)
      do 11 j1 = 1,nparam
         newx(j+1,j1) = x(j1)
c        write(*,*)'j , j1,newx',j+1,j1,newx(j+1,j1)
 11   continue
c.....compute fitness of the second child string
      newfit1(j+1) = funct1(x)
      newfit2(j+1) = funct2(x)
c      newfit(j+1) = newfit1(j+1)
c.....update the individial count in the population
      j = j + 2
      k=k+2
      n=n-2
c.....if the population is already filled up, quit
	if(j .le. ipopsize) go to 181
	
c	  pause
      return
      end




c******tournament selection subroutine********
      subroutine nselect(oldchr1,oldfit1,oldfit2,oldrank,
     1 oldcub_len,oldx,rchr,rfit1,rfit2,rrank,rcub_len,rx)

      common/sgaparam/ipopsize,lchrom,maxgen,ncross,
     -         nmute,pcross,pmute,nparam,pjump

      integer oldchr1(200,1000),oldrank(200)
      integer s1rank,s1chr(1000)
      integer rchr(200,1000),rrank(200)
      double precision oldfit1(200), oldfit2(200),s1cub_len,s2cub_len
      double precision oldcub_len(200),rcub_len(200),s1x(50)
      double precision rx(200,50),rfit1(200),rfit2(200)
      integer rnd,k,n,s2rank,s2chr(1000),rnd1
      double precision rnd2,s1fit1,s1fit2,s2fit1,s2fit2,s2x(50)
      double precision oldx(200,50),rnd3


      k=0

      do n=1,ipopsize
c*****selecting first member******
        rnd2=random()
        rnd2=ipopsize*rnd2
        rnd=nint(rnd2)
c         write(*,*)'rnd',rnd
        if(rnd.eq.0) rnd = ipopsize-k
        if(rnd.eq.ipopsize) rnd=(ipopsize-2)/2
        if(rnd.eq.0) rnd = rnd + 1
c        write(*,*)'rnd',rnd
        s1rank=oldrank(rnd)
        s1cub_len=oldcub_len(rnd)

        do j=1,lchrom
         s1chr(j)=oldchr1(rnd,j)
c         write(*,*)'chr1',s1chr(j)
        end do

        do j=1,nparam
         s1x(j)=oldx(rnd,j)
        end do
        s1fit1=oldfit1(rnd)
        s1fit2=oldfit2(rnd)


C **** SELECTING SECOND MEMBER*******
        rnd3=random()
        rnd3=ipopsize*rnd3
        rnd1=nint(rnd3)
c        write(*,*)'rnd1',rnd1
        if(rnd1.eq.0) rnd1 = ipopsize-n
        if(rnd1.eq.ipopsize) rnd1=(ipopsize-4)/2
        if(rnd1.eq.0) rnd1 = rnd1 + 1
c        write(*,*)'rnd1',rnd1
        s2rank=oldrank(rnd1)
        s2cub_len=oldcub_len(rnd1)

        do j=1,lchrom
         s2chr(j)=oldchr1(rnd1,j)
c         write(*,*)'s2chr',s2chr(j)
        end do

        do j=1,nparam
         s2x(j)=oldx(rnd1,j)
        end do

        s2fit1=oldfit1(rnd1)
        s2fit2=oldfit2(rnd1)

c*****doing tornament selection**********

        if(s1rank .gt. s2rank) then
c*****select 2 nd member**********
c         write(*,*)'******select2******'
         rrank(n)=s2rank
         rcub_len(n)=s2cub_len

         do j=1,lchrom
          rchr(n,j)=s2chr(j)
         end do

         do j=1,nparam
          rx(n,j)=s2x(j)
         end do

         rfit1(n)=s2fit1
         rfit2(n)=s2fit2
        else if(s1rank .lt. s2rank) then
c*****select the 1st member*******\
c          write(*,*)'*******yes1*******'
         rrank(n)=s1rank
         rcub_len(n)=s1cub_len

         do j=1,lchrom
          rchr(n,j)=s1chr(j)
         end do

         do j=1,nparam
          rx(n,j)=s1x(j)
         end do

         rfit1(n)=s1fit1
         rfit2(n)=s1fit2
        else if(s1cub_len .lt. s2cub_len) then
C***select the 2 nd member************
c          write(*,*)'*******yes2******'
         rrank(n)=s2rank
         rcub_len(n)=s2cub_len

         do j=1,lchrom
          rchr(n,j)=s2chr(j)
         end do

         do j=1,nparam
          rx(n,j)=s2x(j)
         end do

         rfit1(n)=s2fit1
         rfit2(n)=s2fit2
        else if(s1cub_len .gt. s2cub_len) then
c *** select the first member************
c          write(*,*)'********yes1**********'
         rrank(n)=s1rank
         rcub_len(n)=s1cub_len

         do j=1,lchrom
          rchr(n,j)=s1chr(j)
         end do

         do j=1,nparam
          rx(n,j)=s1x(j)
         end do

         rfit1(n)=s1fit1
         rfit2(n)=s1fit2
        else
c        write(*,*)'any'
         rrank(n)=s1rank
         rcub_len(n)=s1cub_len

         do j=1,lchrom
          rchr(n,j)=s1chr(j)
         end do

         do j=1,nparam
          rx(n,j)=s1x(j)
         end do

         rfit1(n)=s1fit1
         rfit2(n)=s1fit2
        end if
        k= k+1

      end do

      return
      end


c*******subroutine for the crossover**************'
c     *** performs single-point crossover
c         between mate1 and mate2        ***
      subroutine crossover(ipop,mate1,mate2,rchr,
     -         newchrom)
      common/sgaparam/ipopsize,lchrom,maxgen,ncross,
     -         nmute,pcross,pmute,nparam,pjump
      integer rchr(200,1000)
      integer newchrom(200,1000),jcross
	double precision tempe
c.....check if a crossover is to be performed
      jcross = 0
      If(iflip(pcross) .eq. 1) then
c.....if yes, create a random cross site
         jcross = irnd(1,lchrom-1)
c         write(*,*)'jcross',jcross
         ncross = ncross + 1
      else  jcross = lchrom
      endif
c.....copy till the cross site as it is
      do 171 j = 1,jcross
         newchrom(ipop,  j) = mutation(rchr(mate1,j))
         newchrom(ipop+1,j) = mutation(rchr(mate2,j))
 171  continue
      if(jcross .eq. lchrom) go to 173
c.....swap from the cross site till the end of string
      do 172 j = jcross + 1,lchrom
         newchrom(ipop,  j) = mutation(rchr(mate2,j))
         newchrom(ipop+1,j) = mutation(rchr(mate1,j))
 172  continue
	
 173	do i =ipop,ipop+1
c	write(*,*)'ipop',i
c	do j = 1, lchrom
c	write(*,*)'initial string',i,j,newchrom(i,j)
c	end do
c	pause
       jjump = 0
       If(iflip(pjump) .eq. 1) then
c	    write(*,*)'lets do jumping genes'
c.....if yes, create a random cross site
         jjump1 = irnd(1,lchrom-25)
	   jjump2 = jjump1+25    !irnd(1,lchrom-1)
c	   write(*,*)'jjjjj',jjump1,jjump2
c         write(*,*)'jcross',jcross
c         ncross = ncross + 1
       else
c	   write (*,*)'I am in dead zone going to 251'   
	   jjump1 = jjump2
	   goto  251
       endif

c       If(iflip(pjump) .eq. 1) then
cc	    write(*,*)'lets do jumping genes'
cc.....if yes, create a random cross site
c         jjump1 = irnd(1,lchrom-1)
c	   jjump2 = irnd(1,lchrom-1)
cc	   write(*,*)'jjjjj',jjump1,jjump2
cc         write(*,*)'jcross',jcross
cc         ncross = ncross + 1
c       else
cc	   write (*,*)'I am in dead zone going to 251'   
c	   jjump1 = jjump2
c	   goto  251
c       endif
 
c	if (jjump1 .gt. jjump2)	then 
c   	 tempe = jjump1
c	 jjump1 = jjump2
c	 jjump2 = tempe	 
c	endif
	do j1 = jjump1+1, jjump2
c  *******create random strings of 1 and 0********
        newchrom(i,j1)     = iflip(0.5)
c           oldchr1(j,j1) = chr(j1)
c            write(*,*)'j j1 chrom',j,j1,oldchr1(j,j1)
      end do
c	do j = 1, lchrom
c	 write(*,*)'initial string',i,j,newchrom(i,j)
c	end do
	
     	
251	end do  
	    
      return
      end

		
c     **** returns 1 if ivalue = 0 and vice versa ****
      function logicalnot(ivalue)
      integer ivalue
      logicalnot = 0
      if(ivalue .eq. 0) logicalnot = 1
      return
      end

c     *** mutates ivalue with probability 'pmute' ***
      function mutation(ivalue)
      integer ivalue
      common/sgaparam/ipopsize,lchrom,maxgen,ncross,
     -         nmute,pcross,pmute,nparam,pjump
      mutation = ivalue
c.....check if a mutation is to be performed
      if(iflip(pmute) .eq. 1) then
c....... if yes, perform mutation
         mutation = logicalnot(ivalue)
         nmute = nmute + 1
      endif
      return
      end

c*******making the global population********
c     *****  copy new population to old population *****
      subroutine global(oldchr1,newchrom,oldx,newx,oldfit1,newfit1,
     1 oldfit2,newfit2,globchrom,globx,globfit1,globfit2)

      common/sgaparam/ipopsize,lchrom,maxgen,ncross,
     -         nmute,pcross,pmute,nparam,pjump

      integer oldchr1(200,1000),newchrom(200,1000)
      integer globchrom(400,1000)
      double precision oldx(200,50), newx(200,50)
      double precision oldfit1(200), newfit1(200),newfit2(200)
      double precision oldfit2(200), globfit2(400)
      double precision globx(400,50),globfit1(400)


      do 191 i = 1,ipopsize
c**********copy the parents and children strings*******************
         do 192 j = 1,lchrom
            globchrom(i+ipopsize,j) = newchrom(i,j)
            globchrom(i,j) = oldchr1(i,j)
c            write(*,*)'gold gnew',globchr(i+ipopsize,j),globchr(i,j)
192     continue
c.**********copy the variables***********
         do 193 j = 1,nparam
            globx(i+ipopsize,j) = newx(i,j)
            globx(i,j) = oldx(i,j)
193     continue
c********** finally, copy the fitnesses**************
         globfit1(i+ipopsize) = newfit1(i)
         globfit2(i+ipopsize) = newfit2(i)
         globfit1(i) = oldfit1(i)
         globfit2(i) = oldfit2(i)
191   continue
      return
      end


c*******subroutine of keepalive********

      subroutine gsorting(rnk,sel,grankno,grankar,gcub_len,gflag)

      common/sgaparam/ipopsize,lchrom,maxgen,ncross,
     -         nmute,pcross,pmute,nparam,pjump

      integer rnk,sel,grankno(400),gflag(400),i,j
      integer grankar(400,400),q,a
      double precision gcub_len(400),array1(400,3),temp,temp1

      q= grankno(rnk)
      do i =1,q
       array1(i,1)= grankar(rnk,i)
       a=grankar(rnk,i)
       array1(i,2)=gcub_len(a)

      end do

      do i=1,q-1
       do j = i+1,q
        if(array1(i,2) .le. array1(j,2)) then
         temp=array1(i,2)
         temp1=array1(i,1)
         array1(i,2)=array1(j,2)
         array1(i,1)=array1(j,1)
         array1(j,2)=temp
         array1(j,1)=temp1
        end if
       end do

      end do

      do i=1,sel
       a=array1(i,1)
       gflag(a)=1

      end do

      return
      end



c*******subroutine for the keepalive***********
      subroutine keepalive(globx,globchrom,globfit1,globfit2,keepx,
     1 keepchrom,keepfit1,keepfit2,grank,grankno,gcub_len,
     1 oldrank,oldcub_len)

      common/sgaparam/ipopsize,lchrom,maxgen,ncross,
     -         nmute,pcross,pmute,nparam,pjump

      integer grankar(400,400),oldrank(200)
      integer keeprankno(200),globchrom(400,1000)
      integer grankno(400),z,gmaxrank 
      integer grank(400),gflag(400),poolf,sel
      integer keepchrom(200,1000),i,j,k,m,st,pool
      double precision gcub_len(400),keepfit1(200),oldcub_len(200)
      double precision keepfit2(200),keepx(200,50)
      double precision globx(400,50),globfit1(400)
      double precision globfit2(400),keepcub_len(200)

      do i =1,2*ipopsize
        gcub_len(i)=0.0
        grank(i)=0
        grankno(i)=0
      end do
	  gmaxrank = 0
      call granking(globfit1,globfit2,grank,grankno,gmaxrank,grankar)
	  
	write(*,*)'gmaxrank',gmaxrank
c	pause

      m=gmaxrank
		   
      do i =1,gmaxrank
       call gshare(i,globfit1,globfit2,grankno,grankar,grank,gcub_len)
      end do


      poolf = ipopsize
      pool=0
      do i=1,2*ipopsize
       gflag(i)=0
      end do

      st=0
      z=1
       do i =1,m
        st=pool
        pool=pool+grankno(i)

        if(pool .lt. ipopsize) then
         do k=1,2*ipopsize
          if(grank(k) .eq. i) gflag(k) =1
         end do

        else
         sel=ipopsize-st
c         write(*,*)'selllllll',sel
         call gsorting(i,sel,grankno,grankar,gcub_len,gflag)
         goto 1101
        end if
       end do
c         write(*,*)'hhahklhdsakfh'
c	open(unit = 113, file='res6.txt')

1101   do i=1,2*ipopsize
         if(gflag(i) .eq.1) then
c          write(*,*)'mem',i
          keepfit1(z)=globfit1(i)
          keepfit2(z)=globfit2(i)
	    keepcub_len(z) = gcub_len(i)
c          write(*,*)'hdhhcdh',grank(z)
          do j=1,nparam
           keepx(z,j)= globx(i,j)
c           write(*,*)'kkkk',z,i,keepx(z,j),gcub_len(i)
          end do
          do j=1,lchrom
c           write(*,*)'hhh',i,j, globchrom(i,j)
           keepchrom(z,j)= globchrom(i,j)
c	    write(*,*)'keppp',keepchrom(z,j)

          end do
c	    pause
          z=z+1
         end if
       end do

	 return
       end

c*************subroutines for the ranking of global population**********************

      subroutine granking(globfit1,globfit2,grank,grankno,gmaxrank,
     1           grankar)

      common/sgaparam/ipopsize,lchrom,maxgen,ncross,nmute,pcross,
     1                pmute,nparam,pjump

      double precision globfit1(400),globfit2(400)
      integer grank(400),grankno(400),maxrank2,nondom
      integer rnk,grankar(400,400),gflg(400)
      integer q,i,j,k,val,popsize1,gmaxrank

      popsize1=ipopsize*2
      do i = 1, popsize1
         grank(i)=0
         grankno(i)=0
         gflg(i)=2
      end do

      do i=1,popsize1
        do  j=1,popsize1
             grankar(i,j)=0
        end do
      end do

      rnk=0
      nondom=0
      maxrank1=0
      gmaxrank=0
      do k=1,popsize1
         q=1
         do j=1,popsize1
            if(gflg(j).ne.1) goto 1001
            if(j.eq.popsize1) goto 1002

         end do



1001         rnk = rnk+1
          do j=1,popsize1
            if(gflg(j).eq.0) gflg(j)=2
          end do

          do i=1,popsize1
            if(gflg(i).ne.1 .and. gflg(i).ne.0) then
             do j=1,popsize1
               if(i .ne.j) then
                 if(gflg(j) .ne.1) then
                   val= gvalue(globfit1(i),globfit1(j),globfit2(i),
     1                    globfit2(j))
                   if (val.eq.2) then
                      gflg(i)=0
                      goto 1003
                   end if
                   if (val.eq.1) gflg(j)=0
                   if (val.eq.3) then
                     nondom = nondom+1
                     if(gflg(j).ne.0) gflg(j)=3
                   end if
                 end if
               end if
              if(j .eq. popsize1) then
                grank(i)=rnk
                gflg(i)=1
                grankar(rnk,q)=i
                q = q+1
              end if
             end do
            end if
1003      end do

          grankno(rnk)=q-1
      end do

1002      maxrank2=rnk

      gmaxrank = maxrank2
c	  pause
      return
      end

c*********function indcmp of granking*********************

      function gvalue(pfit11,pfit12,pfit21,pfit22)
      common/sgaparam/ipopsize,lchrom,maxgen,ncross,nmute,pcross,
     1                pmute,nparam,pjump

      double precision  pfit11,pfit12,pfit21,pfit22

c	  write(*,*)'fit',pfit11,pfit12,pfit21,pfit22
      if(((pfit11 .ge. pfit12) .and.((pfit21 - pfit22) .gt.
     1    1e-7)) .or.(((pfit11 - pfit12) .gt.1e-7).and.(pfit21
     1    .ge.pfit22))) then
             gvalue = 1
      else if(((pfit11 .le. pfit12).and.((pfit22 - pfit21).gt.
     1           1e-7)) .or.(((pfit12 - pfit11) .gt.1e-7) .and.
     1           (pfit22 .ge. pfit21))) then
             gvalue=2
           else
             gvalue=3
      end if
c	  write(*,*)'valu=', gvalue
c	  pause
      return
      end

c******subroutine for sharing of global population*************
      subroutine gshare (rnk,globfit1,globfit2,grankno,grankar,grank,
     1           gcub_len)

      common/sgaparam/ipopsize,lchrom,maxgen,ncross,
     -         nmute,pcross,pmute,nparam,pjump

      double precision globfit1(400),globfit2(400)
      double precision gcub_len(400)
      double precision fpara(400,3),length(400,3),max
      integer rnk,grankno(400),grankar(400,400)
      integer grank(400),i,m1,a

      m1 = grankno(rnk)
      do i=1,m1
          fpara(i,1)=0.0
          fpara(i,2)=0.0
          length(i,1)=0.0
          length(i,2)=0.0
      end do
      do i=1,m1
         a= grankar(rnk,i)
         fpara(i,1)=real(a)
         fpara(i,2)=globfit1(a)
      end do

      call globalsort(m1,fpara)
      max = fpara(m1,2)
      do i=1,m1
        if(i.eq.1 .or. i.eq.m1)then
          length(i,1)=fpara(i,1)
          length(i,2)=100*max
        else
          length(i,1)=fpara(i,1)
          length(i,2)=abs(fpara(i+1,2)-fpara(i-1,2))
        end if
      end do
      do i=1,m1
       a=length(i,1)
       gcub_len(a)=gcub_len(a)+length(i,2)
      end do

      do i=1,m1
          fpara(i,1)=0.0
          fpara(i,2)=0.0
          length(i,1)=0.0
          length(i,2)=0.0
      end do

      do i=1,m1
         a= grankar(rnk,i)
         fpara(i,1)=real(a)
         fpara(i,2)=globfit2(a)
      end do
      call globalsort(m1,fpara)
      max = fpara(m1,2)

      do i=1,m1
        if(i.eq.1 .or. i.eq.m1)then
          length(i,1)=fpara(i,1)
          length(i,2)=100*max
        else
          length(i,1)=fpara(i,1)
          length(i,2)=abs(fpara(i+1,2)-fpara(i-1,2))
        end if
      end do

      do i=1,m1
       a=length(i,1)
       gcub_len(a)=gcub_len(a)+length(i,2)
      end do
      return
      end

c*********function sotr is used in sharing*************
      subroutine globalsort(m1,fpara)

      common/sgaparam/ipopsize,lchrom,maxgen,ncross,
     -         nmute,pcross,pmute,nparam,pjump

      integer m1,i1,k1
      double precision temp,temp1,fpara(400,3)

      do k1=1,m1-1
        do i1=k1+1,m1
          if(fpara(k1,2) .gt. fpara(i1,2)) then
             temp=fpara(k1,2)
             temp1=fpara(k1,1)
             fpara(k1,2)=fpara(i1,2)
             fpara(k1,1)=fpara(i1,1)
             fpara(i1,2)=temp
             fpara(i1,1)=temp1
          end if
        end do
      end do
      return
      end