subroutine readprf c c======================================================================= c === c This routine reads in the desired profile types and their === c positions. It then writes the file header for the pe-profiles. === c === c Calls: EXITUS, WRT_HEADER, XY2LL === c === c======================================================================= c c----------------------------------------------------------------------- c Define global data. c----------------------------------------------------------------------- c #include #include #include #include #include #include #include #include #include #if defined resetjulian # include #endif c c----------------------------------------------------------------------- c Define local data. c----------------------------------------------------------------------- c integer i,ios,n,lenstr,nbprf integer ittmin,ittmax integer lnblk FLOAT * dstarf,x,xlon,xlat,y c c======================================================================= c Begin executable code. c======================================================================= c c----------------------------------------------------------------------- c Initialize linked-list structures. c----------------------------------------------------------------------- c do n = 1, (mnbprf-1) icmpos(n,4) = n+1 ictdpos(n,4) = n+1 ixbtpos(n,4) = n+1 end do c icmpos(mnbprf,4) = 0 ictdpos(mnbprf,4) = 0 ixbtpos(mnbprf,4) = 0 c c----------------------------------------------------------------------- c Open sampling I/O files. c----------------------------------------------------------------------- c open (inpprf,file=sampin,status='old') c open (outprf,file=sampout,status='new',iostat=ios) c if (ios.ne.0) then lenstr = lnblk (sampout,len(sampout)) write (stdout,900) sampout(1:lenstr) call exitus ('READPRF') endif c c----------------------------------------------------------------------- c Read in global title, instruments type and associated profile c characterictics. Evaluate the time, the latitude and the longitude c index range as the variables are read. c----------------------------------------------------------------------- c c -- Read file header and title for output file. c n = 1 read (inpprf,'(a)',iostat=ios) htitle c do 10 while ( (n.lt.10) .and. (ios.eq.0) ) n = n + 1 read (inpprf,'(a)',iostat=ios) htitle 10 continue c if (ios.gt.0) then lenstr = lnblk (sampin,len(sampout)) write (stdout,910) 'error',n,sampin(1:lenstr) call exitus ('READPRF') else if (ios.lt.0) then lenstr = lnblk (sampin,len(sampout)) write (stdout,910) 'end of file',n,sampin(1:lenstr) call exitus ('READPRF') endif c c -- Read instrument types and profile positions. c read (inpprf,*,iostat=ios) htype, nbprf if (ios.gt.0) then lenstr = lnblk (sampin,len(sampout)) write (stdout,920) sampin(1:lenstr) call exitus ('READPRF') else if (ios.lt.0) then lenstr = lnblk (sampin,len(sampout)) write (stdout,930) sampin(1:lenstr) call exitus ('READPRF') endif c do 20 while (ios.eq.0) if (nbprf.gt.mnbprf) then write(stdout,940) htype, nbprf, mnbprf call exitus('READPRF') endif lenstr = lnblk (htype,len(htype)) if ((htype(1:lenstr).eq.'XBT').or. & (htype(1:lenstr).eq.'xbt')) then xbt = .true. nbxbt = nbprf read(inpprf,*,iostat=ios) ((ixbtpos(n,i) ,i=1,3) ,n=1,nbxbt) if (ios.gt.0) then write (stdout,950) 'error',htype(1:lenstr) call exitus('READPRF') else if (ios.lt.0) then write (stdout,950) 'end of file',htype(1:lenstr) call exitus('READPRF') else if (nbxbt.lt.mnbprf) then ixbtpos(nbxbt,4) = 0 xbt_bgn = 1 xbt_emt = nbxbt+1 endif else if ((htype(1:lenstr).eq.'CTD').or. & (htype(1:lenstr).eq.'ctd')) then ctd = .true. nbctd = nbprf read(inpprf,*,iostat=ios) ((ictdpos(n,i) ,i=1,3) ,n=1,nbctd) if (ios.gt.0) then write (stdout,950) 'error',htype(1:lenstr) call exitus('READPRF') else if (ios.lt.0) then write (stdout,950) 'end of file',htype(1:lenstr) call exitus('READPRF') else if (nbctd.lt.mnbprf) then ictdpos(nbctd,4) = 0 ctd_bgn = 1 ctd_emt = nbctd+1 endif else if ((htype(1:lenstr).eq.'CM').or. & (htype(1:lenstr).eq.'cm')) then cm = .true. nbcm = nbprf read(inpprf,*,iostat=ios) ((icmpos(n,i) ,i=1,3) ,n=1,nbcm) if (ios.gt.0) then write (stdout,950) 'error',htype(1:lenstr) call exitus('READPRF') else if (ios.lt.0) then write (stdout,950) 'end of file',htype(1:lenstr) call exitus('READPRF') else if (nbcm.lt.mnbprf) then icmpos(nbcm,4) = 0 cm_bgn = 1 cm_emt = nbcm+1 endif else write(stdout,960) htype(1:lenstr) call exitus('READPRF') endif read (inpprf,*,iostat=ios) htype, nbprf if (ios.gt.0) then lenstr = lnblk (sampin,len(sampout)) write (stdout,920) sampin(1:lenstr) call exitus ('READPRF') endif 20 continue c c----------------------------------------------------------------------- c Create header file for PE model data profiles ascii file. c----------------------------------------------------------------------- c c Number of stations or casts. c nhobs = nbxbt + nbctd + nbcm c c Longitude and latitude range (the indexes x,y are on the trcgrid). c if (nbxbt.gt.0) then ittmin = ixbtpos(1,3) ittmax = ixbtpos(1,3) x = FLoaT(ixbtpos(1,1)) y = FLoaT(ixbtpos(1,2)) call xy2ll (x,y,coord,imt,jmt,gridx,gridy,rlngd,rlatd,delx, * dely,thetad,xlon,xlat) hlng_min = xlon hlat_min = xlat hlng_max = xlon hlat_max = xlat elseif (nbctd.gt.0) then ittmin = ictdpos(1,3) ittmax = ictdpos(1,3) x = FLoaT(ictdpos(1,1)) y = FLoaT(ictdpos(1,2)) call xy2ll (x,y,coord,imt,jmt,gridx,gridy,rlngd,rlatd,delx, * dely,thetad,xlon,xlat) hlng_min = xlon hlat_min = xlat hlng_max = xlon hlat_max = xlat elseif (nbcm.gt.0) then ittmin = icmpos(1,3) ittmax = icmpos(1,3) x = FLoaT(icmpos(1,1)) y = FLoaT(icmpos(1,2)) call xy2ll (x,y,coord,imt,jmt,gridx,gridy,rlngd,rlatd,delx, * dely,thetad,xlon,xlat) hlng_min = xlon hlat_min = xlat hlng_max = xlon hlat_max = xlat end if c do 30 n = 1, nbxbt ittmin = min(ittmin,ixbtpos(n,3)) ittmax = max(ittmax,ixbtpos(n,3)) x = FLoaT(ixbtpos(n,1)) y = FLoaT(ixbtpos(n,2)) call xy2ll (x,y,coord,imt,jmt,gridx,gridy,rlngd,rlatd,delx, * dely,thetad,xlon,xlat) hlng_min = min(hlng_min ,xlon) hlat_min = min(hlat_min ,xlat) hlng_max = max(hlng_max ,xlon) hlat_max = max(hlat_max ,xlat) 30 continue c do 40 n = 1, nbctd ittmin = min(ittmin,ictdpos(n,3)) ittmax = max(ittmax,ictdpos(n,3)) x = FLoaT(ictdpos(n,1)) y = FLoaT(ictdpos(n,2)) call xy2ll (x,y,coord,imt,jmt,gridx,gridy,rlngd,rlatd,delx, * dely,thetad,xlon,xlat) hlng_min = min(hlng_min ,xlon) hlat_min = min(hlat_min ,xlat) hlng_max = max(hlng_max ,xlon) hlat_max = max(hlat_max ,xlat) 40 continue c do 50 n = 1, nbcm ittmin = min(ittmin,icmpos(n,3)) ittmax = max(ittmax,icmpos(n,3)) x = FLoaT(icmpos(n,1)) + p5 y = FLoaT(icmpos(n,2)) + p5 call xy2ll (x,y,coord,imt,jmt,gridx,gridy,rlngd,rlatd,delx, * dely,thetad,xlon,xlat) hlng_min = min(hlng_min ,xlon) hlat_min = min(hlat_min ,xlat) hlng_max = max(hlng_max ,xlon) hlat_max = max(hlat_max ,xlat) 50 continue c c Evaluate starting and ending time. c #ifndef resetjulian dstarf = dstart #else dstarf = d0start #endif hstrday = dstarf + (ittmin-1)*dtts*sec2day hendday = dstarf + (ittmax-1)*dtts*sec2day c c Write header. c call wrt_header (outprf) c c Reset all writing switches to off position. c axbt = .false. cm = .false. ctd = .false. xbt = .false. xbts = .false. xctd = .false. c close (inpprf) #ifdef sunflush call flush (outprf) #endif c c======================================================================= c Error messages. c======================================================================= c 900 format (/' READPRF - Unable to open new file:'/11x,1h",a,1h") 910 format (/' READPRF - ',a,' while reading header line ',i2 & ,'of file:'/11x,1h",a,1h") 920 format (/' READPRF - error reading instrument type in file:'/ & 11x,1h",a,1h") 930 format (/' READPRF - premature end of file reading first ', & 'instrument type in file:'/11x,1h",a,1h") 940 format(/' READPRF - Too many profiles selected for instrument ',a/ & 11x,'number requested: ',i10/11x,'maximum allowed: ',i10/ & 11x,'Increase the maximum number of profiles: mnbprf.') 950 format (/' READPRF - ',a,' while reading data for instrument ',a) 960 format(/' READPRF - Illegal data type: ',a) return end