Program Thai Census Data 1990
*     This program reads the Standard Data and outputs the Merged Data
*     merging Mother and Child & Husband and Wife
      
      
*     Declare Real and Integers for programs
      
      integer f1,f2,f3,f4,f5,f6,f7,f8,f9,f10,f11,f12,f13
      logical p1,q1,p2,q2
      character*128 nxt, old
      character*10 lv
      character xi(30)*209
      character ka*11, ka2*16
      integer th, tn, x, y, u, s, m, n, o, p, q, w, pp,qq,qqq,qqqq
      integer th1, th2, thc1, thc2, thc3, thc4, thc5, thc6
      integer rl, sx, ag, mr, lc, ic, ih, ix, i, j, k, l, lnx, lnm
      integer kk, kkk, ss
      character*1 ci(30)
      character*2 cc(30)
      character*33 hi(30)
      character*6 yi, zi(30)
      integer xln(30), mln(30), cr(30), hr(30)
      integer xr(30), ch(30)
C..................................................................
      open (unit=2, file='thai90.clean', status='old',
     $     access='sequential', form='formatted')
      open (unit=3, file='thai90.extract', status='new',recl=210)
      
*     initializing all variables
      
      data ci/30*' '/, hi/30*' '/
      data lv/'0123456789'/
      data xln/30*0/,mln/30*0/,cr/30*0/,hr/30*0/
      data xr/30*0/,ch/30*0/
      
      data ci/30*' '/, hi/30*' '/,xi/30*' '/,yi/' '/
      data nxt/' '/, old/' '/, ka/'        '/
      data rl/0/,sx/0/,ag/0/,mr/0/,lc/0/,ic/0/,ih/0/,ix/0/,i/0/
      data j/0/,k/0/,l/0/,j/0/,k/0/,l/0/,m/0/,n/0/,o/0/,lnx/0/
      data lnm/0/,th/0/,tn/0/,x/0/,y/0/,u/0/,v/0/,s/0/,flag/.true./
      ii=0

         do 3000 while (ii.eq.0)
            old=nxt
            read (2,1,end=1000, err=2000)nxt
 1          format(128A)


**          match husbands and wives   **
	    qq=0
            if ((old(1:26)).ne.(nxt(1:26))) then
	        p1=false
		p2=false
		p=0
		q1=false
		q2=false
               if (ix.gt.0) then
                  do 11 j=1,ix
                     if ((xi(j)(37:37)).eq.'2') then 
                        do 12 k=1,ih
                           if ( ((xr(j).eq.1).and.(hr(k).eq.2)).or.
     $                          ((xr(j).eq.2).and.(hr(k).eq.1)).or.
     $                          (((xr(j).gt.2).and.(xr(j).lt.6))
     $                          .and.(hr(k).eq.6)).or.
     $                          ((xr(j).eq.6).and.((hr(k).gt.2)
     $                          .and.(hr(k).lt.6))).or.
     $                          ((xr(j).gt.6).and.
     $                          (xr(j).eq.hr(k))) ) then
                                xi(j)(143:143)='1'
				xi(j)(144:179)=hi(k)
                                hr(k)=0
                                goto 201
                           end if
 12                     enddo
                     end if


 201                  if ((xi(j)(143:143)).ne.'1') then
   			 xi(j)(143:143)='0'
      			 xi(j)(144:179)=' '
		      endif
 11               enddo
                  
*                 match children and mothers    *
		  kk=1
		  kkk=1
		  ss=0
                  do 301 j=1,ix
                     ka(1:11)='        '
                     if ((xi(j)(37:37)).gt.'1') then
			ka(1:11)='         '
			qq=0
			qqq=0
			qqqq=0
			q1=false
                        do 302 k=kk,ic
			   f1=0
			   f2=0
			   f3=0
			   f4=0
			   f5=0
			   f6=0
			   f7=0
			   f8=0
			   f9=0
			   f10=0
			   f11=0
			   f12=0
			   f13=0
                           s=len(ka)
                           if ((qqq.lt.11).and.(qqq.lt.ch(j))) f1=1
                           if ((mln(k).gt.0).and.(cr(k).ne.5)) f2=1
                           if ((f1.eq.1).and.(f2.eq.1)) f3=1 
                           if ((xr(j).eq.1).or.(xr(j).eq.2)) f4=1
                           if ((cr(k).eq.3).or.(cr(k).eq.4)) f5=1
                           if ((f4.eq.1).and.(f5.eq.1)) f6=1
                           if (((xr(j).gt.2).and.
     $                          (xr(j).lt.7)).and.(cr(k).eq.7))f7=1
                           if (((xr(j).gt.7).and.
     $                          (xr(j).lt.11)).and.(cr(k).eq.10))f8=1
                           if ((xr(j).gt.10).and.(xr(j).eq.cr(k))) f9=1
                           if ((f7.eq.1).or.
     $                          (f8.eq.1).or.(f9.eq.1)) f10=1
                           if ((f6.eq.1).or.(f10.eq.1)) f11=1
                           if ((f11.eq.1).or.(xln(j).eq.mln(k)))f12=1
                           if ((f3.eq.1).and.(f12.eq.1)) f13=1
                           if (f13.eq.1) then
			      q1=true
			      if (ci(k).ne.' ')qqq=qqq+1
			      qq=qq+1
			      kkk=qq
			      if (ci(k).gt.'9') then 
				ka(qqq:qqq)='T'
			      else 
				ka(qqq:qqq)=ci(k)
			      endif
			      ka(qqq:qqq)=ci(k)
                              cr(k)=0
                              mln(k)=0
			      qqqq=qq+qq
                          endif
 302                    continue


                     endif

		  if ((q1.eq.true).and.(qqq.gt.0)) then	
		     xi(j)(180:180)=lv(qqq+1:qqq+1)
		     xi(j)(181:191)=ka
		  else
		     xi(j)(180:180)=lv(qqq+1:qqq+1)
		     xi(j)(181:191)=ka
		  endif

		  kk=kkk
		  ka(1:11)='        '
		  qq=0
		  qqq=0
		  qqqq=0
		  q1=false
		  q2=false
 301              continue
                  
		  qq=0
		  qqq=0
                  
**                tag unmatched children to woman No.1
                  ka2(1:16)='                '
		  p=0
                  do 401 j=1,ic
                     if ((cr(j).gt.0).and.(p.lt.9)) then 
		        p=p+1
			if (ci(j).gt.'9') then 
			  ka2(p:p+1)='T'
			else 
			  ka2(p:p+1)=ci(j)
			endif
			p1=true
		     endif		
 401              continue
                  
		  if ((p1.eq.true).and.(p.lt.1)) then 
			xi(1)(192:192)=' '
			xi(1)(193:193)=lv(1:1)
		  else if ((p1.eq.true).and.
     $ 			   (p.ge.1)) then
			xi(1)(192:192)=' '
			xi(1)(193:193)=lv(p+1:p+1)
			xi(1)(194:209)=ka2
		  else
			xi(1)(194:209)=' '
		  endif



**                writing output		  
                    do j=1,ix
   		    write(3,*)xi(j)
                    enddo
                endif
               
**             resetting all variables
                th=th+1
		ic=0
		ih=0
		ix=0
		lnx=0
		lnm=0
		rl=0
		ag=0
		sx=0
		mr=0
		lc=0

	       do jj=1,30
		xln(jj)=0
		mln(jj)=0
		cr(jj)=0
		hr(jj)=0
		xr(jj)=0
		ch(jj)=0
		ci(jj)=' '
		hi(jj)=' '
		xi(jj)=' '
	       enddo


		ka=' '
		ih=0
		ka(1:11)=' '
		ka2(1:16)=' '
		q=0
		p=0
               tn=0
	       ix=0
           endif
*________________________________________________________________

	   
            if ((nxt(22:22)).eq.'1') then
               read ((nxt(35:38)),'(i4)')lnx
               read ((nxt(39:40)),'(i2)')rl
               read ((nxt(93:94)),'(i2)')ag
               read ((nxt(41:41)),'(i1)')sx

               if (ag.gt.10) then
                  read ((nxt(51:51)),'(i1)')mr
                  read ((nxt(61:62)),'(i2)')lnm
               else
                  read ((nxt(61:62)),'(i2)')lnm
                  mr=0
               end if
               
               if ((sx.eq.2).and.(mr.gt.1).and.(mr.lt.7)) then
                  read ((nxt(78:79)),'(i2)')lc
               else lc=0
               end if
               
               if (lnm.gt.31)lnm=0
            end if	
            
            
            
            if ( (tn.lt.300).and.((rl.gt.0).and.(rl.lt.13)) .and. 
     $           (((ag.ge.0).and.(ag.lt.11)).or. 
     $           ((sx.eq.1).and.(ag.gt.14).and.
     $           (ag.lt.99).and.(mr.eq.2)).or.
     $           ((sx.eq.2).and.(ag.gt.14).and.
     $           (ag.lt.66).and.(mr.lt.7))  ) ) then
               tn=tn+1

*              **keep needed child info**
               if (ag.lt.11)  then
                  ic=ic+1
                  cr(ic)=rl
                  ci(ic)=(nxt(94:94))
		  cc(ic)=(nxt(93:94))
		  if (cc(ic).eq.'10') ci(ic)='T'
                  mln(ic)=lnm

*              **keep needed husband info**
               else if (sx.eq.1) then
                  ih=ih+1
                  hr(ih)=rl
                  hi(ih)=(nxt(93:94))//(nxt(49:50)) ! ag,v19
     $                 //' '//(nxt(75:76))//'  ' ! v28,NA
     $                 //' '//(nxt(77:77))//'  ' ! lit,sc
     $                 //' '//(nxt(52:55)) ! occup
     $                 //' '//(nxt(56:59)) ! indus
     $                 //(nxt(60:60))//(nxt(85:88)) ! v23,v41
     $                 //(nxt(89:90))//'      ' ! v42,6 space

*              **keep needed women info**
               else
                  if ((lc.lt.0).or.(lc.gt.30))lc=0
                  ix=ix+1
                  xr(ix)=rl
                  ch(ix)=lc
                  xln(ix)=lnx
*-------------------------------------------------------------------
*        Attaching computed HH# as character string 


		  if (th.lt.10) then
		    yi(6:6)=lv(th+1:th+1)
		    yi(1:5)='    '
		  else if ((th.ge.10).and.(th.lt.100)) then
		    th1=th
		    thc1=0
		    do while (th1.ge.10)
			th1=th1-10
			thc1=thc1+1
		    enddo
		    yi(6:6)=lv(th1+1:th1+1)
		    yi(5:5)=lv(thc1+1:thc1+1)
		    yi(1:4)='    '
		  else 
		    th2=th
		    thc2=0
		    thc3=0
		    thc4=0
		    thc5=0
		    thc6=0
		    do while (th2.ge.100)
			th2=th2-100
			thc2=thc2+1
			  if (thc2.eq.10) then
			   thc4=thc4+1
			   thc2=0
			   if (thc4.eq.10) then
			     thc5=thc5+1
			     thc4=0
			      if (thc5.eq.10) then
				thc6=thc6+1
				thc5=0
			      endif
			   endif  
			  endif
		    enddo
		    thc3=0
		    do while (th2.ge.10)
			th2=th2-10
			thc3=thc3+1
			if (thc3.eq.10) then
			  thc2=thc2+1
			  thc3=0
			  if (thc2.eq.10) then
			    thc4=thc4+1
			    thc2=0
			    if (thc4.eq.10) then
			      thc5=thc5+1
			      thc4=0
			      if (thc5.eq.10) then
				thc6=thc6+1
				thc5=0
			      endif
			    endif
			  endif
			endif
		    enddo
		    if ((th.ge.100).and.(th.lt.1000)) then
		     yi(6:6)=lv(th2+1:th2+1)
		     yi(5:5)=lv(thc3+1:thc3+1)
		     yi(4:4)=lv(thc2+1:thc2+1)
		     yi(1:3)='   '
		    endif
		    if ((th.ge.1000).and.(th.lt.10000)) then
		     yi(6:6)=lv(th2+1:th2+1)
		     yi(5:5)=lv(thc3+1:thc3+1)
		     yi(4:4)=lv(thc2+1:thc2+1)
		     yi(3:3)=lv(thc4+1:thc4+1)
		     thc4=0
		    endif
		    if ((th.ge.10000).and.(th.lt.100000)) then
		     yi(6:6)=lv(th2+1:th2+1)
		     yi(5:5)=lv(thc3+1:thc3+1)
		     yi(4:4)=lv(thc2+1:thc2+1)
		     yi(3:3)=lv(thc4+1:thc4+1)
		     yi(2:2)=lv(thc5+1:thc5+1)
		     thc4=0
		     thc5=0
		    endif
		    if (th.ge.100000) then
		     yi(6:6)=lv(th2+1:th2+1)
		     yi(5:5)=lv(thc3+1:thc3+1)
		     yi(4:4)=lv(thc2+1:thc2+1)
		     yi(3:3)=lv(thc4+1:thc4+1)
		     yi(2:2)=lv(thc5+1:thc5+1)
		     yi(1:1)=lv(thc6+1:thc6+1)
		     thc4=0
		     thc5=0
		     thc6=0
		    endif
		  endif

*-------------------------------------------------------------------

                  xi(ix)=yi(1:6)//' '//(nxt(1:14))!area var
     $                 //' '//(nxt(27:30)) ! urb, HHsz
     $                 //(nxt(124:128)) !weight
     $                 //(nxt(93:94))//(nxt(39:40)) ! ag,rl
     $                 //' '//(nxt(51:51)) ! mar status
     $                 //'   '//' '//(nxt(31:33)) ! eth, lang
     $                 //'  '//(nxt(63:63)) ! religion
     $                 //'  '//' ' ! res status
     $                 //(nxt(49:50))//' '//(nxt(75:76)) ! v19, v28
     $                 //'  '//' '//(nxt(77:77))//'  ' ! na, lit, sga
     $                 //'  '//'  '//(nxt(64:65))//'    ' ! mig, br1-2
     $                 //'  '//(nxt(68:69)) ! prvres1
     $                 //'  '//(nxt(70:71)) ! prvres2
     $                 //(nxt(66:67)) ! dur res
     $                 //' '//(nxt(72:74)) ! v33, v34
     $                 //'  ' ! AgeMar
     $                 //'  ' ! DurMar
     $                 //'  '//'  ' ! OthMar
     $                 //' '//' '//' '//(nxt(84:84)) !bcl-2
     $                 //(nxt(95:96))//'  '//'  ' ! cebl-3
     $                 //(nxt(97:98))//(nxt(78:81)) ! lch1-3
     $                 //(nxt(82:83))//'        ' ! ChDead,Others
     $                 //' '//(nxt(52:55)) ! occup
     $                 //' '//(nxt(56:59)) ! indus
     $                 //(nxt(60:60))//(nxt(85:88)) ! v23,v41
     $                 //(nxt(89:90))//'      ' ! v42
               end if
	  
            end if

 3000    continue
 2000 write (6,*)'ERROR CODE'
 1000 write (6,*)'EOF - Natural Exit'
      write (6,*)'Closing input and output files'
      close (2)
      close (3)
      stop
      end