Ejemplo n.º 1
0
/* volume in half dB
 * don't check input values */
static void set_hp_vol(int vol_l, int vol_r)
{
    /* minimum is -57.5dB and max is 6dB in DAC mode
     * and -51.5dB / 12dB in Line1 mode */
    int min = input_line1 ? -103 : -115;
    int max = input_line1 ? 24 : 12;

    vol_l = MAX(min, MIN(vol_l, max));
    vol_r = MAX(min, MIN(vol_r, max));
    /* unmute, enable zero cross and set volume.*/
#if IMX233_SUBTARGET >= 3700
    unsigned mstr_zcd = BM_AUDIOOUT_HPVOL_EN_MSTR_ZCD;
#else
    unsigned mstr_zcd = 0;
#endif
    HW_AUDIOOUT_HPVOL = mstr_zcd | BF_OR3(AUDIOOUT_HPVOL, SELECT(input_line1),
        VOL_LEFT(max - vol_l), VOL_RIGHT(max - vol_r));
}
Ejemplo n.º 2
0
DSTATUS disk_initialize (void)
{
	BYTE n, cmd, ty, ocr[4];
	UINT tmr;

#if _USE_WRITE
	if (CardType && MMC_SEL) disk_writep(0, 0);	/* Finalize write process if it is in progress */
#endif
	spi_card_init();		/* Initialize ports to control MMC */
	DESELECT();
	for (n = 10; n; n--) spi_card_rcv();	/* 80 dummy clocks with CS=H */
	SELECT();
	for (n = 2; n; n--) spi_card_rcv();

	ty = 0;
	if (send_cmd(CMD0, 0) == 0x01) {			/* Enter Idle state */
		if (send_cmd(CMD8, 0x1AA) == 1) {	/* SDv2 */
			for (n = 0; n < 4; n++) ocr[n] = spi_card_rcv();		/* Get trailing return value of R7 resp */
			if (ocr[2] == 0x01 && ocr[3] == 0xAA) {			/* The card can work at vdd range of 2.7-3.6V */
				for (tmr = 10000; tmr && send_cmd(ACMD41, 1UL << 30); tmr--) _delay_us(100);	/* Wait for leaving idle state (ACMD41 with HCS bit) */
				if (tmr && send_cmd(CMD58, 0) == 0) {		/* Check CCS bit in the OCR */
					for (n = 0; n < 4; n++) ocr[n] = spi_card_rcv();
					ty = (ocr[0] & 0x40) ? CT_SD2 | CT_BLOCK : CT_SD2;	/* SDv2 (HC or SC) */
				}
			}
		} else {							/* SDv1 or MMCv3 */
		    for (tmr = 2000; tmr && (send_cmd(ACMD41, 0)>1); tmr--) _delay_us(100);
			if (tmr) 	{
				ty = CT_SD1; cmd = ACMD41;	/* SDv1 */
			} else {
				ty = CT_MMC; cmd = CMD1;	/* MMCv3 */
			}
			for (tmr = 1000; tmr && send_cmd(cmd, 0); tmr--) _delay_us(1000);	/* Wait for leaving idle state */
			if (!tmr || send_cmd(CMD16, 512) != 0)			/* Set R/W block length to 512 */
				ty = 0;
		}
	}
	CardType = ty;
	DESELECT();
	spi_card_rcv();
	spi_card_vollgas();

	return ty ? 0 : STA_NOINIT;
}
Ejemplo n.º 3
0
int
heapsort(void *vbase, size_t nmemb, size_t size,
    int (*compar)(const void *, const void *))
#endif
{
	size_t cnt, i, j, l;
	char tmp, *tmp1, *tmp2;
	char *base, *k, *p, *t;

	if (nmemb <= 1)
		return (0);

	if (!size) {
		errno = EINVAL;
		return (-1);
	}

	if ((k = malloc(size)) == NULL)
		return (-1);

	/*
	 * Items are numbered from 1 to nmemb, so offset from size bytes
	 * below the starting address.
	 */
	base = (char *)vbase - size;

	for (l = nmemb / 2 + 1; --l;)
		CREATE(l, nmemb, i, j, t, p, size, cnt, tmp);

	/*
	 * For each element of the heap, save the largest element into its
	 * final slot, save the displaced element (k), then recreate the
	 * heap.
	 */
	while (nmemb > 1) {
		COPY(k, base + nmemb * size, cnt, size, tmp1, tmp2);
		COPY(base + nmemb * size, base + size, cnt, size, tmp1, tmp2);
		--nmemb;
		SELECT(i, j, nmemb, t, p, size, k, cnt, tmp1, tmp2);
	}
	free(k);
	return (0);
}
Ejemplo n.º 4
0
TEST(select_outputs, order)
{
  tools::wallet2 w;

  // check that most unrelated heights are picked in order
  tools::wallet2::transfer_container transfers = make_transfers_container(5);
  transfers[0].m_block_height = 700;
  transfers[1].m_block_height = 700;
  transfers[2].m_block_height = 704;
  transfers[3].m_block_height = 716;
  transfers[4].m_block_height = 701;
  std::vector<size_t> unused_indices({0, 1, 2, 3, 4});
  std::vector<size_t> selected;
  SELECT(0);
  PICK(3); // first the one that's far away
  PICK(2); // then the one that's close
  PICK(4); // then the one that's adjacent
  PICK(1); // then the one that's on the same height
}
Ejemplo n.º 5
0
//------------------------------------------------------------------------------------
//  Записывает блок данных в SRAM-буффер dataflash
//	Параметры: BufferNo   -> Номер буффера (1 или 2)
//                  Addr       -> Адрес в буффере с которого начинать чтение
//                  Count      -> Количество байт, которое необходимо записать
//  		   *BufferPtr -> Буффер, данные из которого нужно записать
//------------------------------------------------------------------------------------
void df_WriteStr( uint8 BufferNo, uint16 Addr, uint16 Count, uint8 *BufferPtr )
{
   SELECT();

   if ( BufferNo == 1 )	{ DF_SPI_RW(Buf1Write); }       // буффер 1
   else	if ( BufferNo == 2 ) { DF_SPI_RW(Buf2Write); }  // буффер 2
   else { DESELECT(); return; }                         // ошиблись с номером буффера

   DF_SPI_RW(0x00);
   DF_SPI_RW((unsigned char)(Addr>>8));
   DF_SPI_RW((unsigned char)(Addr));
   for( uint16 i=0; i<Count; i++)
   {
      DF_SPI_RW(*(BufferPtr));
      BufferPtr++;
   }


   DESELECT();
}
Ejemplo n.º 6
0
//------------------------------------------------------------------------------------
//  Читает один байт из SRAM-буффера dataflash
//	Параметры: BufferNo -> Номер буффера (1 или 2)
//                  Addr  -> Адрес в буффере
//------------------------------------------------------------------------------------
uint8 df_GetChar(uint8 BufferNo, uint16 Addr )
{
   uint8 data;

   SELECT();

   if ( BufferNo == 1 )	{ DF_SPI_RW(Buf1Read); }       // буффер 1
   else	if ( BufferNo == 2 ) { DF_SPI_RW(Buf2Read); }  // буффер 2
   else { DESELECT(); return 0; }                      // ошиблись с номером буффера

   DF_SPI_RW(0x00);              // цикл чтения описан в даташите
   DF_SPI_RW((uint8)(Addr>>8));
   DF_SPI_RW((uint8)(Addr));
   DF_SPI_RW(0x00);
   data = DF_SPI_RW(0x00);

   DESELECT();

   return data;
}
Ejemplo n.º 7
0
//------------------------------------------------------------------------------------
//  Прочитать блок данных непосредственно из Flash - памяти
//	Параметры: PageAdr    -> Номер страницы, с которой начинать чтение
//                  Addr       -> Адрес в странице, с которого начинать чтение
//                  Count      -> Количество байт, которое необходимо прочитать
//  		   *BufferPtr -> Адрес буффера в который заносить данные
//------------------------------------------------------------------------------------
void df_FlashRead( uint16 PageAdr, uint16 Addr, uint16 Count, uint8 *BufferPtr )
{
   SELECT();

   DF_SPI_RW(ContArrayRead);
   DF_SPI_RW((unsigned char)(PageAdr >> (16 - df_Info.page_bit)));
   DF_SPI_RW((unsigned char)((PageAdr << (df_Info.page_bit - 8))+ (Addr>>8)));
   DF_SPI_RW((unsigned char)(Addr));
   DF_SPI_RW(0x00);
   DF_SPI_RW(0x00);
   DF_SPI_RW(0x00);
   DF_SPI_RW(0x00);

   for( uint16 i=0; i < Count; i++ )
   {
      *(BufferPtr) = DF_SPI_RW(0x00);
      BufferPtr++;
   }

   DESELECT();
}
Ejemplo n.º 8
0
bool SimpleSocket::isReadyReceive(int timeout)
{
  timeval time;
  fd_set read, write, except;
  int rc = this->SOCKET_FAIL;
  bool rtn = false;
  
  // The select function uses the timeval data structure
  time.tv_sec = timeout/1000;
  time.tv_usec = (timeout%1000)*1000;
  
  FD_ZERO(&read);
  FD_ZERO(&write);
  FD_ZERO(&except);
  
  FD_SET(this->getSockHandle(), &read);
  
  rc = SELECT(this->getSockHandle() + 1, &read, &write, &except, &time);
  
  if (this->SOCKET_FAIL != rc)
  {
    if (0==rc)
    {
      LOG_DEBUG("Socket select timed out");
      rtn = false;
    }
    else
    {
      LOG_DEBUG("Data is ready for reading");
      rtn = true;
    }
  }
  else
  {
    this->logSocketError("Socket select function failed", rc);
    rtn = false;
  }
  
  return rtn;
}
Ejemplo n.º 9
0
//-----------------------------------------------------------------------
// Send a command packet to MMC                                          
//-----------------------------------------------------------------------
static
BYTE send_cmd (
	BYTE cmd,		// Command byte 
	DWORD arg		// Argument 
)
{
	BYTE n, res;


	if (cmd & 0x80) {	// ACMD<n> is the command sequense of CMD55-CMD<n> 
		cmd &= 0x7F;
		res = send_cmd(CMD55, 0);
		if (res > 1) return res;
	}

	// Select the card 
	DESELECT();
	rcv_spi();
	SELECT();
	rcv_spi();

	// Send a command packet 
	xmit_spi(cmd);						// Start + Command index 
	xmit_spi((BYTE)(arg >> 24));		// Argument[31..24] 
	xmit_spi((BYTE)(arg >> 16));		// Argument[23..16] 
	xmit_spi((BYTE)(arg >> 8));			// Argument[15..8] 
	xmit_spi((BYTE)arg);				// Argument[7..0] 
	n = 0x01;							// Dummy CRC + Stop 
	if (cmd == CMD0) n = 0x95;			// Valid CRC for CMD0(0) 
	if (cmd == CMD8) n = 0x87;			// Valid CRC for CMD8(0x1AA) 
	xmit_spi(n);

	// Receive a command response 
	n = 10;								// Wait for a valid response in timeout of 10 attempts 
	do {
		res = rcv_spi();
	} while ((res & 0x80) && --n);

	return res;			// Return with the response value 
}
Ejemplo n.º 10
0
static
BYTE send_cmd (
	BYTE cmd,		/* 1st byte (Start + Index) */
	DWORD arg		/* Argument (32 bits) */
)
{
	BYTE n, res;


	if (cmd & 0x80) {	/* ACMD<n> is the command sequense of CMD55-CMD<n> */
		cmd &= 0x7F;
		res = send_cmd(CMD55, 0);
		if (res > 1) return res;
	}

	/* Select the card */
	DESELECT();
	SPI_RECEIVE();
	SELECT();
	SPI_RECEIVE();

	/* Send a command packet */
	SPI_SEND((BYTE)cmd);						/* Start + Command index */
	SPI_SEND((BYTE)(arg >> 24));		/* Argument[31..24] */
	SPI_SEND((BYTE)(arg >> 16));		/* Argument[23..16] */
	SPI_SEND((BYTE)(arg >> 8));			/* Argument[15..8] */
	SPI_SEND((BYTE)arg);				/* Argument[7..0] */
	n = 0x01;							/* Dummy CRC + Stop */
	if (cmd == CMD0) n = 0x95;			/* Valid CRC for CMD0(0) */
	if (cmd == CMD8) n = 0x87;			/* Valid CRC for CMD8(0x1AA) */
	SPI_SEND(n);

	/* Receive a command response */
	n = 10;								/* Wait for a valid response in timeout of 10 attempts */
	do {
		res = SPI_RECEIVE();
	} while ((res & 0x80) && --n);

	return res;			/* Return with the response value */
}
Ejemplo n.º 11
0
int vfc_pcf8584_init(struct vfc_dev *dev) 
{
	/* This will also choose register S0_OWN so we can set it. */
	WRITE_S1(RESET);

	/* The pcf8584 shifts this value left one bit and uses
	 * it as its i2c bus address.
	 */
	WRITE_REG(0x55000000);

	/* This will set the i2c bus at the same speed sun uses,
	 * and set another magic bit.
	 */
	WRITE_S1(SELECT(S2));
	WRITE_REG(0x14000000);
	
	/* Enable the serial port, idle the i2c bus and set
	 * the data reg to s0.
	 */
	WRITE_S1(CLEAR_I2C_BUS);
	udelay(100);
	return 0;
}
Ejemplo n.º 12
0
int main()
{
	char cmd[CMDLEN]; //command string
	
	printf("Welcome to pSQL by 20061201 Kim Dong-Gyu\n");

	while(1){
		__fpurge(stdin); //keep buffer out
		
		printf("pSQL>>"); //prompt
		scanf("%s", cmd); //take a command
	
		if(strcmp(cmd, "CREATE") == 0){
			CREATE();	
		}
		else if(strcmp(cmd, "INFO") == 0){
			INFO();
		}
		else if(strcmp(cmd, "DROP") == 0){
			DROP();
		}
		else if(strcmp(cmd, "QUIT") == 0){
			QUIT();
			return 0;
		}
		else if(strcmp(cmd, "SELECT") == 0){
			SELECT();
		}
		//when a command is fault
		else{
			printf("Please give me a correct command!!\n");
		}
	}

	return 0;
}
Ejemplo n.º 13
0
QList<T *> DataMapper<Subclass, T, I>::find(const QString & whereClause)
{
    return basicFind(SELECT("*").FROM(table()).WHERE(whereClause));
}
Ejemplo n.º 14
0
DSTATUS disk_initialize(void)
{
	u8 n, cmd, ty, ocr[4], rep, timeout;
	u16 tmr;

	power_on();							/* Force socket power on */

	for (n = 10; n; n--) xmit_spi(0xFF);	/* Dummy clocks */

	ty = 0;
	timeout=100;

    // Trying to enter Idle state
	do {
		DESELECT();
		xmit_spi(0xFF);
		SELECT();
		rep = send_cmd(CMD0,0);
	} while ((rep != 1) && (--timeout));

    if(timeout == 0)
    {
		DESELECT();
		xmit_spi(0xFF);
		SELECT();
		rep = send_cmd(CMD12,0);
		rep = send_cmd(CMD0,0);
		if (rep != 1)
        {
            return STA_NOINIT;
        }
	}

	rep = send_cmd(CMD8, 0x1AA);

    // SDHC
	if ( rep == 1)
    {
		for (n = 0; n < 4; n++) ocr[n] = rcvr_spi();		/* Get trailing return value of R7 resp */

		if (ocr[2] == 0x01 && ocr[3] == 0xAA) {				/* The card can work at vdd range of 2.7-3.6V */
			for (tmr = 25000; tmr && send_cmd(ACMD41, 1UL << 30); tmr--) ;	/* Wait for leaving idle state (ACMD41 with HCS bit) */

			if (tmr && send_cmd(CMD58, 0) == 0) {		/* Check CCS bit in the OCR */
				for (n = 0; n < 4; n++) ocr[n] = rcvr_spi();
				ty = (ocr[0] & 0x40) ? CT_SD2 | CT_BLOCK : CT_SD2;	/* SDv2 */
			}
		}

	}

    // SDSC or MMC
    else
    {
		if (send_cmd(ACMD41, 0) <= 1) 	{
			ty = CT_SD1; cmd = ACMD41;	/* SDv1 */
		} else {
			ty = CT_MMC; cmd = CMD1;	/* MMCv3 */
		}

		for (tmr = 25000; tmr && send_cmd(cmd, 0); tmr--) ;	/* Wait for leaving idle state */

		if (!tmr || send_cmd(CMD16, 512) != 0)			/* Set R/W block length to 512 */
			ty = 0;

	}

	CardType = ty;
	release_spi();

    // Initialization succeded
	if (ty)
    {
		FCLK_FAST();
		return RES_OK;
	}

    // Initialization failed
    else
    {
		power_off();
		return STA_NOINIT;
	}
}
Ejemplo n.º 15
0
int testAMMI(int argc,char** argv ) {
int j,i=0;
unsigned char test1[] = { 1,25,50,75,100,125,128,150,175,200,225,250,254}	;
unsigned char test2[] = { 0x55,0x55,0xAA,0xAA,0x55,0x55,0xAA,0xAA}	;
unsigned char test3[] = { 0x00,0x00,0xFF,0xFF,0x00,0x00,0xFF,0xFF}	;
unsigned char atr[]  = { 0x3b ,0x7e ,0x13 ,0x0 ,0x0 ,0x80 ,0x53 ,0xff ,0xff ,0xff ,0x62 ,0x0 ,0xff ,0x71 ,0xbf ,0x83 ,0x7 ,0x90 ,0x0 ,0x90,0};
int res;
data = alloca(300);
buffer = alloca(300);
	//checkATR(atr);
	/* Try to set T=0 protocol */
	printit("Try to set protocol T1");
	data[0]=0x00;
	data[1]=0x07;
	dwSendLength= 7;
	SELECT(02,data,buffer,dwSendLength);
	DO_TRANSMIT(SCARD_PCI_T1,1);
	myprintf("Set protocol T0 \n");
	myprintf("Test No. 1 \n");
/* Test1 */	
	data[0]=0x00;
	data[1]=0x10;
	dwSendLength= 7;
	SELECT(02,data,buffer,dwSendLength);
	printit("SELECT FILE EFptsDataCheck");
	DO_TRANSMIT(SCARD_PCI_T0,0);
	dwSendLength=5;
	printit("READ BINARY 256 Byte(s)");
	READBIN(0,0,0,data,buffer,dwSendLength);
	DO_TRANSMIT(SCARD_PCI_T0,0);
   
	myprintf("Test No. 2\n");
	data[0]=0x00;
    data[1]=0x10;
    dwSendLength= 7;
    SELECT(02,data,buffer,dwSendLength);
    printit("SELECT FILE EFptsDataCheck");
    DO_TRANSMIT(SCARD_PCI_T0,0);
	for(j=0;j<255;j++) 
		data[j]=j;
	printit("WRITE BINARY 255 Byte(s)");
	dwSendLength=255+5;
	UPDATEBIN(0,0,255,data,buffer,dwSendLength);
	DO_TRANSMIT(SCARD_PCI_T0,0);
	myprintf("Test No. 3 \n");
	data[0]=0xA0;
	data[1]=0x00;
	dwSendLength= 7;
	SELECT(02,data,buffer,dwSendLength);
	printit("SELECT FILE EFresult");
	DO_TRANSMIT(SCARD_PCI_T0,0);
	printit("READ  BINARY FILE EFResult");
	dwSendLength=5;
	READBIN(0,0,04,data,buffer,dwSendLength);
	DO_TRANSMIT(SCARD_PCI_T0,0) ;       
	res=r[1];
	dwSendLength=5;
	printit("READ  BINARY FILE EFresult");
	READBIN(0,0x0A,0x0E,data,buffer,dwSendLength);
	DO_TRANSMIT(SCARD_PCI_T0,0) ;       
	printit("\'PTS\'");
	if( r[11] == res ) 
		myprintf("Passed \n");
	else {
		myprintf("Failed \n");
		fails++;
	}
	printit("\'PTS data check\'");
	if( r[13] == res )
		myprintf("Passed \n");
	else {
		myprintf("Failed \n");
		fails++;
	}
	return fails;	
}
Ejemplo n.º 16
0
int main(int argc,char *argv[])
{
  struct timeval currTime;
  int sockfd;
  int port;

  //check arguments here
  if (argc != 3) {
	  printf("usage: %s <port#> <logFile>\n", argv[0]);
	  return 0;
  }
  
  // set port number var
  port = atoi(argv[1]);
  
  // copy log file name into log_filename
  memcpy(log_filename,argv[2],strlen(argv[2]));
  
  // log the start of the server
  gettimeofday(&currTime,NULL);
  _log(log_filename,"Server started");
  
  /*
   * Open a TCP socket (an Internet stream socket).
   */
  sockfd = setup_socket(port);
  
  /*
   * here you should listen() on your TCP socket
   */
  listen(sockfd,5);
  
  SELECT_INIT();
  for ( ; ; ) //endless loop
  {
    SELECT(); 
    if(s == 0) {
      // timeout, do nothing
    }
	  
    if (s > 0) { // something ready for read, probably a client connection request
      int n, r;
      socklen_t clilen;
      int newsockfd;
      struct sockaddr_in cli_addr;
      char buffer[100];
      char welcome_msg[100];
      pthread_t th;

      clilen = sizeof(cli_addr);
      
      // accept connection
      newsockfd = accept(sockfd, (struct sockaddr *) &cli_addr, &clilen);

      if (newsockfd < 0) error("ERROR on accept");
      FD_SET(newsockfd, &rdset);
      max_fd = newsockfd + 1;

      // check select to see if client is sending their username
      s = select(max_fd, &rdset, &wrset, NULL, &selectTimeout); 
      if (s == -1) { printf("ERROR: Socket error. Exiting.\n"); exit(1); }

      if (s > 0) {
        bzero(buffer,100);
        n = recv(newsockfd,buffer,100,0);
        if (n < 0) error("ERROR reading from socket");
    
        // since a new user connected, let's review the current file list
        char *filelist_buf = malloc(sizeof(struct UserFile)*FILELIST_LEN);
        build_file_list(filelist_buf);
        printf("%s just started connecting. This is the updated file list from all clients:\n%s\n",buffer,filelist_buf); 
        
        // add user to users hash
        pthread_mutex_lock(&mutex);
          struct User *user = malloc(sizeof(struct User));
          strcpy(user->name,buffer);
          memcpy(&(user->addr),&cli_addr,sizeof(struct sockaddr_in));
          user->sockfd = newsockfd;
          add_user(user);
	      pthread_mutex_unlock(&mutex);

        // send welcome message
        strcpy(welcome_msg,"Welcome, ");
        strcat(welcome_msg, buffer);
        strcat(welcome_msg,". You are now connected.");
        n = send(newsockfd,welcome_msg,strlen(welcome_msg),0); 

        // notify other users that a new user has joined
        /*
        struct User *u;
        char *new_user_msg = malloc(128);
        strcpy(new_user_msg,"New user connected: ");
        for(u = users; u != NULL; u = u->hh.next) {
          if (strcmp(u->name,buffer) != 0) {
            sprintf(new_user_msg,"A new user has joined: %s\n",buffer);
            n = send(u->sockfd,new_user_msg,strlen(new_user_msg),0);
          }
        }
        */
        r = pthread_create(&th, 0, connection, (void *)user);
        if (r != 0) { fprintf(stderr, "thread create failed\n"); }
      }

      if (s == 0) {
        printf("Client did not send username\n");
      }
    }
  }
 
  //if you've accepted the connection, you'll probably want to
	//check "select()" to see if they're trying to send data, 
    //like their name, and if so
	//recv() whatever they're trying to send

	//since you're talking nicely now.. probably a good idea send them
	//a message to welcome them to the new client.

	//if there are others connected to the server, probably good to notify them
	//that someone else has joined.


	//pthread_mutex_lock(&mutex);
	//now add your new user to your global list of users
	//pthread_mutex_unlock(&mutex);

	//now you need to start a thread to take care of the 
	//rest of the messages for that client
	//r = pthread_create(&th, 0, connection, (void *)newsockfd);
	//if (r != 0) { fprintf(stderr, "thread create failed\n"); }

	//A requirement for 5273 students:
	//at this point...
	//whether or not someone connected, you should probably
	//look for clients that should be timed out
	//and kick them out
	//oh, and notify everyone that they're gone.

}
Ejemplo n.º 17
0
void DAC7512_chip_select(uint16_t cs_arg) {
	SELECT(BIT3);
}
Ejemplo n.º 18
0
int sdc_init(void) {
	
	int i;
	uint8 n, ty = 0, ocr[4];
	
    if(initted)
        return 0;
	
	if(spi_init(0)) {
		return -1;
	}
	
	timer_spin_sleep(20);
	SELECT();
	
	/* 80 dummy clocks */
	for (n = 10; n; n--) 
		(void)spi_slow_sr_byte(0xff);

	
	if (send_slow_cmd(CMD0, 0) == 1) {			/* Enter Idle state */

#ifdef SD_DEBUG
		dbglog(DBG_DEBUG, "%s: Enter Idle state\n", __func__);
#endif
		timer_spin_sleep(20);
//		thd_sleep(100);
		
		i = 0;
		
		if (send_slow_cmd(CMD8, 0x1AA) == 1) {	/* SDC Ver2+  */
		
			for (n = 0; n < 4; n++) 
				ocr[n] = spi_slow_sr_byte(0xff);
			
			if (ocr[2] == 0x01 && ocr[3] == 0xAA) { /* The card can work at vdd range of 2.7-3.6V */
			
				do {
					
					/* ACMD41 with HCS bit */
					if (send_slow_cmd(CMD55, 0) <= 1 && send_slow_cmd(CMD41, 1UL << 30) == 0) 
						break;
						
					++i;
					
				} while (i < 300000);
				
				if (i < 300000 && send_slow_cmd(CMD58, 0) == 0) { /* Check CCS bit */
				
					for (n = 0; n < 4; n++) 
						ocr[n] = spi_slow_sr_byte(0xff);
						
					ty = (ocr[0] & 0x40) ? 6 : 2;
				}
			}
			
		} else { /* SDC Ver1 or MMC */
		
			ty = (send_slow_cmd(CMD55, 0) <= 1 && send_slow_cmd(CMD41, 0) <= 1) ? 2 : 1; /* SDC : MMC */
			
			do {
				
				if (ty == 2) {
					
					if (send_slow_cmd(CMD55, 0) <= 1 && send_slow_cmd(CMD41, 0) == 0) /* ACMD41 */
						break;
						
				} else {
					
					if (send_slow_cmd(CMD1, 0) == 0) { /* CMD1 */
						is_mmc = 1;
						break;
					}								
				}
				
				++i;
				
			} while (i < 300000);
			
			if (!(i < 300000) || send_slow_cmd(CMD16, 512) != 0)	/* Select R/W block length */
				ty = 0;
		}
	}
	
	send_slow_cmd(CMD59, 1);		// crc check
	
#ifdef SD_DEBUG
	dbglog(DBG_DEBUG, "%s: card type = 0x%02x\n", __func__, ty & 0xff);
#endif

	if(!(ty & 4)) {
		byte_mode = 1;
	}
	
	DESELECT();
	(void)spi_slow_sr_byte(0xff); /* Idle (Release DO) */

	if (ty) { /* Initialization succeded */
//		sdc_print_ident();
		initted = 1;
		return 0;
	}
	
	/* Initialization failed */
	sdc_shutdown();
	return -1;
}
Ejemplo n.º 19
0
void pci_init_board(void)
{
	int mem_target, mem_attr, i;
	int bus = 0;
	u32 reg;
	u32 soc_ctrl = readl(MVEBU_SYSTEM_REG_BASE + 0x4);

	/* Check SoC Control Power State */
	debug("%s: SoC Control %08x, 0en %01lx, 1en %01lx, 2en %01lx\n",
	      __func__, soc_ctrl, SELECT(soc_ctrl, 0), SELECT(soc_ctrl, 1),
	      SELECT(soc_ctrl, 2));

	for (i = 0; i < MAX_PEX; i++) {
		struct mvebu_pcie *pcie = &pcie_bus[i];
		struct pci_controller *hose = &pcie->hose;

		/* Get port number, lane number and memory target / attr */
		mvebu_get_port_lane(pcie, i, &mem_target, &mem_attr);

		/* Don't read at all from pci registers if port power is down */
		if (pcie->lane == 0 && SELECT(soc_ctrl, pcie->port) == 0) {
			i += 3;
			debug("%s: skipping port %d\n", __func__, pcie->port);
			continue;
		}

		pcie->base = (void __iomem *)PCIE_BASE(i);

		/* Check link and skip ports that have no link */
		if (!mvebu_pcie_link_up(pcie)) {
			debug("%s: PCIe %d.%d - down\n", __func__,
			      pcie->port, pcie->lane);
			continue;
		}
		debug("%s: PCIe %d.%d - up, base %08x\n", __func__,
		      pcie->port, pcie->lane, (u32)pcie->base);

		/* Read Id info and local bus/dev */
		debug("direct conf read %08x, local bus %d, local dev %d\n",
		      readl(pcie->base), mvebu_pcie_get_local_bus_nr(pcie),
		      mvebu_pcie_get_local_dev_nr(pcie));

		mvebu_pcie_set_local_bus_nr(pcie, bus);
		mvebu_pcie_set_local_dev_nr(pcie, 0);
		pcie->dev = PCI_BDF(bus, 0, 0);

		pcie->mem.start = (u32)mvebu_pcie_membase;
		pcie->mem.end = pcie->mem.start + PCIE_MEM_SIZE - 1;
		mvebu_pcie_membase += PCIE_MEM_SIZE;

		if (mvebu_mbus_add_window_by_id(mem_target, mem_attr,
						(phys_addr_t)pcie->mem.start,
						PCIE_MEM_SIZE)) {
			printf("PCIe unable to add mbus window for mem at %08x+%08x\n",
			       (u32)pcie->mem.start, PCIE_MEM_SIZE);
		}

		/* Setup windows and configure host bridge */
		mvebu_pcie_setup_wins(pcie);

		/* Master + slave enable. */
		reg = readl(pcie->base + PCIE_CMD_OFF);
		reg |= PCI_COMMAND_MEMORY;
		reg |= PCI_COMMAND_MASTER;
		reg |= BIT(10);		/* disable interrupts */
		writel(reg, pcie->base + PCIE_CMD_OFF);

		/* Setup U-Boot PCI Controller */
		hose->first_busno = 0;
		hose->current_busno = bus;

		/* PCI memory space */
		pci_set_region(hose->regions + 0, pcie->mem.start,
			       pcie->mem.start, PCIE_MEM_SIZE, PCI_REGION_MEM);
		pci_set_region(hose->regions + 1,
			       0, 0,
			       gd->ram_size,
			       PCI_REGION_MEM | PCI_REGION_SYS_MEMORY);
		hose->region_count = 2;

		pci_set_ops(hose,
			    pci_hose_read_config_byte_via_dword,
			    pci_hose_read_config_word_via_dword,
			    mvebu_pcie_read_config_dword,
			    pci_hose_write_config_byte_via_dword,
			    pci_hose_write_config_word_via_dword,
			    mvebu_pcie_write_config_dword);
		pci_register_hose(hose);

		hose->last_busno = pci_hose_scan(hose);

		/* Set BAR0 to internal registers */
		writel(SOC_REGS_PHY_BASE, pcie->base + PCIE_BAR_LO_OFF(0));
		writel(0, pcie->base + PCIE_BAR_HI_OFF(0));

		bus = hose->last_busno + 1;
	}
}
Ejemplo n.º 20
0
/**
 * Select chip.
 */
void AD5504_chip_select(uint16_t cs_arg) {
	SELECT(PIN_CS1);
}
Ejemplo n.º 21
0
/* Subroutine */ int ztgevc_(char *side, char *howmny, logical *select, 
	integer *n, doublecomplex *a, integer *lda, doublecomplex *b, integer 
	*ldb, doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *
	ldvr, integer *mm, integer *m, doublecomplex *work, doublereal *rwork,
	 integer *info)
{
/*  -- LAPACK routine (version 2.0) --   
       Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
       Courant Institute, Argonne National Lab, and Rice University   
       September 30, 1994   



    Purpose   
    =======   

    ZTGEVC computes some or all of the right and/or left generalized   
    eigenvectors of a pair of complex upper triangular matrices (A,B).   

    The right generalized eigenvector x and the left generalized   
    eigenvector y of (A,B) corresponding to a generalized eigenvalue   
    w are defined by:   

            (A - wB) * x = 0  and  y**H * (A - wB) = 0   

    where y**H denotes the conjugate tranpose of y.   

    If an eigenvalue w is determined by zero diagonal elements of both A 
  
    and B, a unit vector is returned as the corresponding eigenvector.   

    If all eigenvectors are requested, the routine may either return   
    the matrices X and/or Y of right or left eigenvectors of (A,B), or   
    the products Z*X and/or Q*Y, where Z and Q are input unitary   
    matrices.  If (A,B) was obtained from the generalized Schur   
    factorization of an original pair of matrices   
       (A0,B0) = (Q*A*Z**H,Q*B*Z**H),   
    then Z*X and Q*Y are the matrices of right or left eigenvectors of   
    A.   

    Arguments   
    =========   

    SIDE    (input) CHARACTER*1   
            = 'R': compute right eigenvectors only;   
            = 'L': compute left eigenvectors only;   
            = 'B': compute both right and left eigenvectors.   

    HOWMNY  (input) CHARACTER*1   
            = 'A': compute all right and/or left eigenvectors;   
            = 'B': compute all right and/or left eigenvectors, and   
                   backtransform them using the input matrices supplied   
                   in VR and/or VL;   
            = 'S': compute selected right and/or left eigenvectors,   
                   specified by the logical array SELECT.   

    SELECT  (input) LOGICAL array, dimension (N)   
            If HOWMNY='S', SELECT specifies the eigenvectors to be   
            computed.   
            If HOWMNY='A' or 'B', SELECT is not referenced.   
            To select the eigenvector corresponding to the j-th   
            eigenvalue, SELECT(j) must be set to .TRUE..   

    N       (input) INTEGER   
            The order of the matrices A and B.  N >= 0.   

    A       (input) COMPLEX*16 array, dimension (LDA,N)   
            The upper triangular matrix A.   

    LDA     (input) INTEGER   
            The leading dimension of array A.  LDA >= max(1,N).   

    B       (input) COMPLEX*16 array, dimension (LDB,N)   
            The upper triangular matrix B.  B must have real diagonal   
            elements.   

    LDB     (input) INTEGER   
            The leading dimension of array B.  LDB >= max(1,N).   

    VL      (input/output) COMPLEX*16 array, dimension (LDVL,MM)   
            On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must   
            contain an N-by-N matrix Q (usually the unitary matrix Q   
            of left Schur vectors returned by ZHGEQZ).   
            On exit, if SIDE = 'L' or 'B', VL contains:   
            if HOWMNY = 'A', the matrix Y of left eigenvectors of (A,B); 
  
            if HOWMNY = 'B', the matrix Q*Y;   
            if HOWMNY = 'S', the left eigenvectors of (A,B) specified by 
  
                        SELECT, stored consecutively in the columns of   
                        VL, in the same order as their eigenvalues.   
            If SIDE = 'R', VL is not referenced.   

    LDVL    (input) INTEGER   
            The leading dimension of array VL.   
            LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise.   

    VR      (input/output) COMPLEX*16 array, dimension (LDVR,MM)   
            On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must   
            contain an N-by-N matrix Q (usually the unitary matrix Z   
            of right Schur vectors returned by ZHGEQZ).   
            On exit, if SIDE = 'R' or 'B', VR contains:   
            if HOWMNY = 'A', the matrix X of right eigenvectors of (A,B); 
  
            if HOWMNY = 'B', the matrix Z*X;   
            if HOWMNY = 'S', the right eigenvectors of (A,B) specified by 
  
                        SELECT, stored consecutively in the columns of   
                        VR, in the same order as their eigenvalues.   
            If SIDE = 'L', VR is not referenced.   

    LDVR    (input) INTEGER   
            The leading dimension of the array VR.   
            LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise.   

    MM      (input) INTEGER   
            The leading dimension of the array VR.   
            LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise.   

    MM      (input) INTEGER   
            The number of columns in the arrays VL and/or VR. MM >= M.   

    M       (output) INTEGER   
            The number of columns in the arrays VL and/or VR actually   
            used to store the eigenvectors.  If HOWMNY = 'A' or 'B', M   
            is set to N.  Each selected eigenvector occupies one column. 
  

    WORK    (workspace) COMPLEX*16 array, dimension (2*N)   

    RWORK   (workspace) DOUBLE PRECISION array, dimension (2*N)   

    INFO    (output) INTEGER   
            = 0:  successful exit.   
            < 0:  if INFO = -i, the i-th argument had an illegal value.   

    ===================================================================== 
  


       Decode and Test the input parameters   

    
   Parameter adjustments   
       Function Body */
    /* Table of constant values */
    static doublecomplex c_b1 = {0.,0.};
    static doublecomplex c_b2 = {1.,0.};
    static integer c__1 = 1;
    
    /* System generated locals */
    integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1, 
	    vr_offset, i__1, i__2, i__3, i__4, i__5;
    doublereal d__1, d__2, d__3, d__4, d__5, d__6;
    doublecomplex z__1, z__2, z__3, z__4;
    /* Builtin functions */
    double d_imag(doublecomplex *);
    void d_cnjg(doublecomplex *, doublecomplex *), z_div(doublecomplex *, 
	    doublecomplex *, doublecomplex *);
    /* Local variables */
    static integer ibeg, ieig, iend;
    static doublereal dmin__;
    static integer isrc;
    static doublereal temp;
    static doublecomplex suma, sumb;
    static doublereal xmax;
    static doublecomplex d;
    static integer i, j;
    static doublereal scale;
    static logical ilall;
    static integer iside;
    static doublereal sbeta;
    extern logical lsame_(char *, char *);
    static doublereal small;
    static logical compl;
    static doublereal anorm, bnorm;
    static logical compr;
    extern /* Subroutine */ int zgemv_(char *, integer *, integer *, 
	    doublecomplex *, doublecomplex *, integer *, doublecomplex *, 
	    integer *, doublecomplex *, doublecomplex *, integer *);
    static doublecomplex ca, cb;
    extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
    static logical ilbbad;
    static doublereal acoefa;
    static integer je;
    static doublereal bcoefa, acoeff;
    static doublecomplex bcoeff;
    static logical ilback;
    static integer im;
    static doublereal ascale, bscale;
    extern doublereal dlamch_(char *);
    static integer jr;
    static doublecomplex salpha;
    static doublereal safmin;
    extern /* Subroutine */ int xerbla_(char *, integer *);
    static doublereal bignum;
    static logical ilcomp;
    static integer ihwmny;
    static doublereal big;
    static logical lsa, lsb;
    static doublereal ulp;
    static doublecomplex sum;



#define SELECT(I) select[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]

#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
#define VL(I,J) vl[(I)-1 + ((J)-1)* ( *ldvl)]
#define VR(I,J) vr[(I)-1 + ((J)-1)* ( *ldvr)]

    if (lsame_(howmny, "A")) {
	ihwmny = 1;
	ilall = TRUE_;
	ilback = FALSE_;
    } else if (lsame_(howmny, "S")) {
	ihwmny = 2;
	ilall = FALSE_;
	ilback = FALSE_;
    } else if (lsame_(howmny, "B") || lsame_(howmny, "T")) {
	ihwmny = 3;
	ilall = TRUE_;
	ilback = TRUE_;
    } else {
	ihwmny = -1;
    }

    if (lsame_(side, "R")) {
	iside = 1;
	compl = FALSE_;
	compr = TRUE_;
    } else if (lsame_(side, "L")) {
	iside = 2;
	compl = TRUE_;
	compr = FALSE_;
    } else if (lsame_(side, "B")) {
	iside = 3;
	compl = TRUE_;
	compr = TRUE_;
    } else {
	iside = -1;
    }

/*     Count the number of eigenvectors */

    if (! ilall) {
	im = 0;
	i__1 = *n;
	for (j = 1; j <= *n; ++j) {
	    if (SELECT(j)) {
		++im;
	    }
/* L10: */
	}
    } else {
	im = *n;
    }

/*     Check diagonal of B */

    ilbbad = FALSE_;
    i__1 = *n;
    for (j = 1; j <= *n; ++j) {
	if (d_imag(&B(j,j)) != 0.) {
	    ilbbad = TRUE_;
	}
/* L20: */
    }

    *info = 0;
    if (iside < 0) {
	*info = -1;
    } else if (ihwmny < 0) {
	*info = -2;
    } else if (*n < 0) {
	*info = -4;
    } else if (*lda < max(1,*n)) {
	*info = -6;
    } else if (ilbbad) {
	*info = -7;
    } else if (*ldb < max(1,*n)) {
	*info = -8;
    } else if (compl && *ldvl < *n || *ldvl < 1) {
	*info = -10;
    } else if (compr && *ldvr < *n || *ldvr < 1) {
	*info = -12;
    } else if (*mm < im) {
	*info = -13;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("ZTGEVC", &i__1);
	return 0;
    }

/*     Quick return if possible */

    *m = im;
    if (*n == 0) {
	return 0;
    }

/*     Machine Constants */

    safmin = dlamch_("Safe minimum");
    big = 1. / safmin;
    dlabad_(&safmin, &big);
    ulp = dlamch_("Epsilon") * dlamch_("Base");
    small = safmin * *n / ulp;
    big = 1. / small;
    bignum = 1. / (safmin * *n);

/*     Compute the 1-norm of each column of the strictly upper triangular 
  
       part of A and B to check for possible overflow in the triangular   
       solver. */

    i__1 = a_dim1 + 1;
    anorm = (d__1 = A(1,1).r, abs(d__1)) + (d__2 = d_imag(&A(1,1)), 
	    abs(d__2));
    i__1 = b_dim1 + 1;
    bnorm = (d__1 = B(1,1).r, abs(d__1)) + (d__2 = d_imag(&B(1,1)), 
	    abs(d__2));
    RWORK(1) = 0.;
    RWORK(*n + 1) = 0.;
    i__1 = *n;
    for (j = 2; j <= *n; ++j) {
	RWORK(j) = 0.;
	RWORK(*n + j) = 0.;
	i__2 = j - 1;
	for (i = 1; i <= j-1; ++i) {
	    i__3 = i + j * a_dim1;
	    RWORK(j) += (d__1 = A(i,j).r, abs(d__1)) + (d__2 = d_imag(&A(i,j)), abs(d__2));
	    i__3 = i + j * b_dim1;
	    RWORK(*n + j) += (d__1 = B(i,j).r, abs(d__1)) + (d__2 = d_imag(&
		    B(i,j)), abs(d__2));
/* L30: */
	}
/* Computing MAX */
	i__2 = j + j * a_dim1;
	d__3 = anorm, d__4 = RWORK(j) + ((d__1 = A(j,j).r, abs(d__1)) + (
		d__2 = d_imag(&A(j,j)), abs(d__2)));
	anorm = max(d__3,d__4);
/* Computing MAX */
	i__2 = j + j * b_dim1;
	d__3 = bnorm, d__4 = RWORK(*n + j) + ((d__1 = B(j,j).r, abs(d__1)) + 
		(d__2 = d_imag(&B(j,j)), abs(d__2)));
	bnorm = max(d__3,d__4);
/* L40: */
    }

    ascale = 1. / max(anorm,safmin);
    bscale = 1. / max(bnorm,safmin);

/*     Left eigenvectors */

    if (compl) {
	ieig = 0;

/*        Main loop over eigenvalues */

	i__1 = *n;
	for (je = 1; je <= *n; ++je) {
	    if (ilall) {
		ilcomp = TRUE_;
	    } else {
		ilcomp = SELECT(je);
	    }
	    if (ilcomp) {
		++ieig;

		i__2 = je + je * a_dim1;
		i__3 = je + je * b_dim1;
		if ((d__1 = A(je,je).r, abs(d__1)) + (d__2 = d_imag(&A(je,je)), abs(d__2)) <= safmin && (d__3 = B(je,je).r,
			 abs(d__3)) <= safmin) {

/*                 Singular matrix pencil -- return unit e
igenvector */

		    i__2 = *n;
		    for (jr = 1; jr <= *n; ++jr) {
			i__3 = jr + ieig * vl_dim1;
			VL(jr,ieig).r = 0., VL(jr,ieig).i = 0.;
/* L50: */
		    }
		    i__2 = ieig + ieig * vl_dim1;
		    VL(ieig,ieig).r = 1., VL(ieig,ieig).i = 0.;
		    goto L140;
		}

/*              Non-singular eigenvalue:   
                Compute coefficients  a  and  b  in   
                     H   
                   y  ( a A - b B ) = 0   

   Computing MAX */
		i__2 = je + je * a_dim1;
		i__3 = je + je * b_dim1;
		d__4 = ((d__1 = A(je,je).r, abs(d__1)) + (d__2 = d_imag(&A(je,je)), abs(d__2))) * ascale, d__5 = (d__3 = 
			B(je,je).r, abs(d__3)) * bscale, d__4 = max(d__4,d__5);
		temp = 1. / max(d__4,safmin);
		i__2 = je + je * a_dim1;
		z__2.r = temp * A(je,je).r, z__2.i = temp * A(je,je).i;
		z__1.r = ascale * z__2.r, z__1.i = ascale * z__2.i;
		salpha.r = z__1.r, salpha.i = z__1.i;
		i__2 = je + je * b_dim1;
		sbeta = temp * B(je,je).r * bscale;
		acoeff = sbeta * ascale;
		z__1.r = bscale * salpha.r, z__1.i = bscale * salpha.i;
		bcoeff.r = z__1.r, bcoeff.i = z__1.i;

/*              Scale to avoid underflow */

		lsa = abs(sbeta) >= safmin && abs(acoeff) < small;
		lsb = (d__1 = salpha.r, abs(d__1)) + (d__2 = d_imag(&salpha), 
			abs(d__2)) >= safmin && (d__3 = bcoeff.r, abs(d__3)) 
			+ (d__4 = d_imag(&bcoeff), abs(d__4)) < small;

		scale = 1.;
		if (lsa) {
		    scale = small / abs(sbeta) * min(anorm,big);
		}
		if (lsb) {
/* Computing MAX */
		    d__3 = scale, d__4 = small / ((d__1 = salpha.r, abs(d__1))
			     + (d__2 = d_imag(&salpha), abs(d__2))) * min(
			    bnorm,big);
		    scale = max(d__3,d__4);
		}
		if (lsa || lsb) {
/* Computing MIN   
   Computing MAX */
		    d__5 = 1., d__6 = abs(acoeff), d__5 = max(d__5,d__6), 
			    d__6 = (d__1 = bcoeff.r, abs(d__1)) + (d__2 = 
			    d_imag(&bcoeff), abs(d__2));
		    d__3 = scale, d__4 = 1. / (safmin * max(d__5,d__6));
		    scale = min(d__3,d__4);
		    if (lsa) {
			acoeff = ascale * (scale * sbeta);
		    } else {
			acoeff = scale * acoeff;
		    }
		    if (lsb) {
			z__2.r = scale * salpha.r, z__2.i = scale * salpha.i;
			z__1.r = bscale * z__2.r, z__1.i = bscale * z__2.i;
			bcoeff.r = z__1.r, bcoeff.i = z__1.i;
		    } else {
			z__1.r = scale * bcoeff.r, z__1.i = scale * bcoeff.i;
			bcoeff.r = z__1.r, bcoeff.i = z__1.i;
		    }
		}

		acoefa = abs(acoeff);
		bcoefa = (d__1 = bcoeff.r, abs(d__1)) + (d__2 = d_imag(&
			bcoeff), abs(d__2));
		xmax = 1.;
		i__2 = *n;
		for (jr = 1; jr <= *n; ++jr) {
		    i__3 = jr;
		    WORK(jr).r = 0., WORK(jr).i = 0.;
/* L60: */
		}
		i__2 = je;
		WORK(je).r = 1., WORK(je).i = 0.;
/* Computing MAX */
		d__1 = ulp * acoefa * anorm, d__2 = ulp * bcoefa * bnorm, 
			d__1 = max(d__1,d__2);
		dmin__ = max(d__1,safmin);

/*                                              H   
                Triangular solve of  (a A - b B)  y = 0   

                                        H   
                (rowwise in  (a A - b B) , or columnwise in a 
A - b B) */

		i__2 = *n;
		for (j = je + 1; j <= *n; ++j) {

/*                 Compute   
                         j-1   
                   SUM = sum  conjg( a*A(k,j) - b*B(k,j) )
*x(k)   
                         k=je   
                   (Scale if necessary) */

		    temp = 1. / xmax;
		    if (acoefa * RWORK(j) + bcoefa * RWORK(*n + j) > bignum * 
			    temp) {
			i__3 = j - 1;
			for (jr = je; jr <= j-1; ++jr) {
			    i__4 = jr;
			    i__5 = jr;
			    z__1.r = temp * WORK(jr).r, z__1.i = temp * 
				    WORK(jr).i;
			    WORK(jr).r = z__1.r, WORK(jr).i = z__1.i;
/* L70: */
			}
			xmax = 1.;
		    }
		    suma.r = 0., suma.i = 0.;
		    sumb.r = 0., sumb.i = 0.;

		    i__3 = j - 1;
		    for (jr = je; jr <= j-1; ++jr) {
			d_cnjg(&z__3, &A(jr,j));
			i__4 = jr;
			z__2.r = z__3.r * WORK(jr).r - z__3.i * WORK(jr)
				.i, z__2.i = z__3.r * WORK(jr).i + z__3.i * 
				WORK(jr).r;
			z__1.r = suma.r + z__2.r, z__1.i = suma.i + z__2.i;
			suma.r = z__1.r, suma.i = z__1.i;
			d_cnjg(&z__3, &B(jr,j));
			i__4 = jr;
			z__2.r = z__3.r * WORK(jr).r - z__3.i * WORK(jr)
				.i, z__2.i = z__3.r * WORK(jr).i + z__3.i * 
				WORK(jr).r;
			z__1.r = sumb.r + z__2.r, z__1.i = sumb.i + z__2.i;
			sumb.r = z__1.r, sumb.i = z__1.i;
/* L80: */
		    }
		    z__2.r = acoeff * suma.r, z__2.i = acoeff * suma.i;
		    d_cnjg(&z__4, &bcoeff);
		    z__3.r = z__4.r * sumb.r - z__4.i * sumb.i, z__3.i = 
			    z__4.r * sumb.i + z__4.i * sumb.r;
		    z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
		    sum.r = z__1.r, sum.i = z__1.i;

/*                 Form x(j) = - SUM / conjg( a*A(j,j) - b
*B(j,j) )   

                   with scaling and perturbation of the de
nominator */

		    i__3 = j + j * a_dim1;
		    z__3.r = acoeff * A(j,j).r, z__3.i = acoeff * A(j,j).i;
		    i__4 = j + j * b_dim1;
		    z__4.r = bcoeff.r * B(j,j).r - bcoeff.i * B(j,j).i, 
			    z__4.i = bcoeff.r * B(j,j).i + bcoeff.i * B(j,j)
			    .r;
		    z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i;
		    d_cnjg(&z__1, &z__2);
		    d.r = z__1.r, d.i = z__1.i;
		    if ((d__1 = d.r, abs(d__1)) + (d__2 = d_imag(&d), abs(
			    d__2)) <= dmin__) {
			z__1.r = dmin__, z__1.i = 0.;
			d.r = z__1.r, d.i = z__1.i;
		    }

		    if ((d__1 = d.r, abs(d__1)) + (d__2 = d_imag(&d), abs(
			    d__2)) < 1.) {
			if ((d__1 = sum.r, abs(d__1)) + (d__2 = d_imag(&sum), 
				abs(d__2)) >= bignum * ((d__3 = d.r, abs(d__3)
				) + (d__4 = d_imag(&d), abs(d__4)))) {
			    temp = 1. / ((d__1 = sum.r, abs(d__1)) + (d__2 = 
				    d_imag(&sum), abs(d__2)));
			    i__3 = j - 1;
			    for (jr = je; jr <= j-1; ++jr) {
				i__4 = jr;
				i__5 = jr;
				z__1.r = temp * WORK(jr).r, z__1.i = temp * 
					WORK(jr).i;
				WORK(jr).r = z__1.r, WORK(jr).i = z__1.i;
/* L90: */
			    }
			    xmax = temp * xmax;
			    z__1.r = temp * sum.r, z__1.i = temp * sum.i;
			    sum.r = z__1.r, sum.i = z__1.i;
			}
		    }
		    i__3 = j;
		    z__2.r = -sum.r, z__2.i = -sum.i;
		    z_div(&z__1, &z__2, &d);
		    WORK(j).r = z__1.r, WORK(j).i = z__1.i;
/* Computing MAX */
		    i__3 = j;
		    d__3 = xmax, d__4 = (d__1 = WORK(j).r, abs(d__1)) + (
			    d__2 = d_imag(&WORK(j)), abs(d__2));
		    xmax = max(d__3,d__4);
/* L100: */
		}

/*              Back transform eigenvector if HOWMNY='B'. */

		if (ilback) {
		    i__2 = *n + 1 - je;
		    zgemv_("N", n, &i__2, &c_b2, &VL(1,je), ldvl, 
			    &WORK(je), &c__1, &c_b1, &WORK(*n + 1), &c__1)
			    ;
		    isrc = 2;
		    ibeg = 1;
		} else {
		    isrc = 1;
		    ibeg = je;
		}

/*              Copy and scale eigenvector into column of VL 
*/

		xmax = 0.;
		i__2 = *n;
		for (jr = ibeg; jr <= *n; ++jr) {
/* Computing MAX */
		    i__3 = (isrc - 1) * *n + jr;
		    d__3 = xmax, d__4 = (d__1 = WORK((isrc-1)**n+jr).r, abs(d__1)) + (
			    d__2 = d_imag(&WORK((isrc - 1) * *n + jr)), abs(
			    d__2));
		    xmax = max(d__3,d__4);
/* L110: */
		}

		if (xmax > safmin) {
		    temp = 1. / xmax;
		    i__2 = *n;
		    for (jr = ibeg; jr <= *n; ++jr) {
			i__3 = jr + ieig * vl_dim1;
			i__4 = (isrc - 1) * *n + jr;
			z__1.r = temp * WORK((isrc-1)**n+jr).r, z__1.i = temp * WORK(
				(isrc-1)**n+jr).i;
			VL(jr,ieig).r = z__1.r, VL(jr,ieig).i = z__1.i;
/* L120: */
		    }
		} else {
		    ibeg = *n + 1;
		}

		i__2 = ibeg - 1;
		for (jr = 1; jr <= ibeg-1; ++jr) {
		    i__3 = jr + ieig * vl_dim1;
		    VL(jr,ieig).r = 0., VL(jr,ieig).i = 0.;
/* L130: */
		}

	    }
L140:
	    ;
	}
    }

/*     Right eigenvectors */

    if (compr) {
	ieig = im + 1;

/*        Main loop over eigenvalues */

	for (je = *n; je >= 1; --je) {
	    if (ilall) {
		ilcomp = TRUE_;
	    } else {
		ilcomp = SELECT(je);
	    }
	    if (ilcomp) {
		--ieig;

		i__1 = je + je * a_dim1;
		i__2 = je + je * b_dim1;
		if ((d__1 = A(je,je).r, abs(d__1)) + (d__2 = d_imag(&A(je,je)), abs(d__2)) <= safmin && (d__3 = B(je,je).r,
			 abs(d__3)) <= safmin) {

/*                 Singular matrix pencil -- return unit e
igenvector */

		    i__1 = *n;
		    for (jr = 1; jr <= *n; ++jr) {
			i__2 = jr + ieig * vr_dim1;
			VR(jr,ieig).r = 0., VR(jr,ieig).i = 0.;
/* L150: */
		    }
		    i__1 = ieig + ieig * vr_dim1;
		    VR(ieig,ieig).r = 1., VR(ieig,ieig).i = 0.;
		    goto L250;
		}

/*              Non-singular eigenvalue:   
                Compute coefficients  a  and  b  in   

                ( a A - b B ) x  = 0   

   Computing MAX */
		i__1 = je + je * a_dim1;
		i__2 = je + je * b_dim1;
		d__4 = ((d__1 = A(je,je).r, abs(d__1)) + (d__2 = d_imag(&A(je,je)), abs(d__2))) * ascale, d__5 = (d__3 = 
			B(je,je).r, abs(d__3)) * bscale, d__4 = max(d__4,d__5);
		temp = 1. / max(d__4,safmin);
		i__1 = je + je * a_dim1;
		z__2.r = temp * A(je,je).r, z__2.i = temp * A(je,je).i;
		z__1.r = ascale * z__2.r, z__1.i = ascale * z__2.i;
		salpha.r = z__1.r, salpha.i = z__1.i;
		i__1 = je + je * b_dim1;
		sbeta = temp * B(je,je).r * bscale;
		acoeff = sbeta * ascale;
		z__1.r = bscale * salpha.r, z__1.i = bscale * salpha.i;
		bcoeff.r = z__1.r, bcoeff.i = z__1.i;

/*              Scale to avoid underflow */

		lsa = abs(sbeta) >= safmin && abs(acoeff) < small;
		lsb = (d__1 = salpha.r, abs(d__1)) + (d__2 = d_imag(&salpha), 
			abs(d__2)) >= safmin && (d__3 = bcoeff.r, abs(d__3)) 
			+ (d__4 = d_imag(&bcoeff), abs(d__4)) < small;

		scale = 1.;
		if (lsa) {
		    scale = small / abs(sbeta) * min(anorm,big);
		}
		if (lsb) {
/* Computing MAX */
		    d__3 = scale, d__4 = small / ((d__1 = salpha.r, abs(d__1))
			     + (d__2 = d_imag(&salpha), abs(d__2))) * min(
			    bnorm,big);
		    scale = max(d__3,d__4);
		}
		if (lsa || lsb) {
/* Computing MIN   
   Computing MAX */
		    d__5 = 1., d__6 = abs(acoeff), d__5 = max(d__5,d__6), 
			    d__6 = (d__1 = bcoeff.r, abs(d__1)) + (d__2 = 
			    d_imag(&bcoeff), abs(d__2));
		    d__3 = scale, d__4 = 1. / (safmin * max(d__5,d__6));
		    scale = min(d__3,d__4);
		    if (lsa) {
			acoeff = ascale * (scale * sbeta);
		    } else {
			acoeff = scale * acoeff;
		    }
		    if (lsb) {
			z__2.r = scale * salpha.r, z__2.i = scale * salpha.i;
			z__1.r = bscale * z__2.r, z__1.i = bscale * z__2.i;
			bcoeff.r = z__1.r, bcoeff.i = z__1.i;
		    } else {
			z__1.r = scale * bcoeff.r, z__1.i = scale * bcoeff.i;
			bcoeff.r = z__1.r, bcoeff.i = z__1.i;
		    }
		}

		acoefa = abs(acoeff);
		bcoefa = (d__1 = bcoeff.r, abs(d__1)) + (d__2 = d_imag(&
			bcoeff), abs(d__2));
		xmax = 1.;
		i__1 = *n;
		for (jr = 1; jr <= *n; ++jr) {
		    i__2 = jr;
		    WORK(jr).r = 0., WORK(jr).i = 0.;
/* L160: */
		}
		i__1 = je;
		WORK(je).r = 1., WORK(je).i = 0.;
/* Computing MAX */
		d__1 = ulp * acoefa * anorm, d__2 = ulp * bcoefa * bnorm, 
			d__1 = max(d__1,d__2);
		dmin__ = max(d__1,safmin);

/*              Triangular solve of  (a A - b B) x = 0  (colum
nwise)   

                WORK(1:j-1) contains sums w,   
                WORK(j+1:JE) contains x */

		i__1 = je - 1;
		for (jr = 1; jr <= je-1; ++jr) {
		    i__2 = jr;
		    i__3 = jr + je * a_dim1;
		    z__2.r = acoeff * A(jr,je).r, z__2.i = acoeff * A(jr,je).i;
		    i__4 = jr + je * b_dim1;
		    z__3.r = bcoeff.r * B(jr,je).r - bcoeff.i * B(jr,je).i, 
			    z__3.i = bcoeff.r * B(jr,je).i + bcoeff.i * B(jr,je)
			    .r;
		    z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
		    WORK(jr).r = z__1.r, WORK(jr).i = z__1.i;
/* L170: */
		}
		i__1 = je;
		WORK(je).r = 1., WORK(je).i = 0.;

		for (j = je - 1; j >= 1; --j) {

/*                 Form x(j) := - w(j) / d   
                   with scaling and perturbation of the de
nominator */

		    i__1 = j + j * a_dim1;
		    z__2.r = acoeff * A(j,j).r, z__2.i = acoeff * A(j,j).i;
		    i__2 = j + j * b_dim1;
		    z__3.r = bcoeff.r * B(j,j).r - bcoeff.i * B(j,j).i, 
			    z__3.i = bcoeff.r * B(j,j).i + bcoeff.i * B(j,j)
			    .r;
		    z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
		    d.r = z__1.r, d.i = z__1.i;
		    if ((d__1 = d.r, abs(d__1)) + (d__2 = d_imag(&d), abs(
			    d__2)) <= dmin__) {
			z__1.r = dmin__, z__1.i = 0.;
			d.r = z__1.r, d.i = z__1.i;
		    }

		    if ((d__1 = d.r, abs(d__1)) + (d__2 = d_imag(&d), abs(
			    d__2)) < 1.) {
			i__1 = j;
			if ((d__1 = WORK(j).r, abs(d__1)) + (d__2 = d_imag(
				&WORK(j)), abs(d__2)) >= bignum * ((d__3 = 
				d.r, abs(d__3)) + (d__4 = d_imag(&d), abs(
				d__4)))) {
			    i__1 = j;
			    temp = 1. / ((d__1 = WORK(j).r, abs(d__1)) + (
				    d__2 = d_imag(&WORK(j)), abs(d__2)));
			    i__1 = je;
			    for (jr = 1; jr <= je; ++jr) {
				i__2 = jr;
				i__3 = jr;
				z__1.r = temp * WORK(jr).r, z__1.i = temp * 
					WORK(jr).i;
				WORK(jr).r = z__1.r, WORK(jr).i = z__1.i;
/* L180: */
			    }
			}
		    }

		    i__1 = j;
		    i__2 = j;
		    z__2.r = -WORK(j).r, z__2.i = -WORK(j).i;
		    z_div(&z__1, &z__2, &d);
		    WORK(j).r = z__1.r, WORK(j).i = z__1.i;

		    if (j > 1) {

/*                    w = w + x(j)*(a A(*,j) - b B(*,j
) ) with scaling */

			i__1 = j;
			if ((d__1 = WORK(j).r, abs(d__1)) + (d__2 = d_imag(
				&WORK(j)), abs(d__2)) > 1.) {
			    i__1 = j;
			    temp = 1. / ((d__1 = WORK(j).r, abs(d__1)) + (
				    d__2 = d_imag(&WORK(j)), abs(d__2)));
			    if (acoefa * RWORK(j) + bcoefa * RWORK(*n + j) >= 
				    bignum * temp) {
				i__1 = je;
				for (jr = 1; jr <= je; ++jr) {
				    i__2 = jr;
				    i__3 = jr;
				    z__1.r = temp * WORK(jr).r, z__1.i = 
					    temp * WORK(jr).i;
				    WORK(jr).r = z__1.r, WORK(jr).i = 
					    z__1.i;
/* L190: */
				}
			    }
			}

			i__1 = j;
			z__1.r = acoeff * WORK(j).r, z__1.i = acoeff * 
				WORK(j).i;
			ca.r = z__1.r, ca.i = z__1.i;
			i__1 = j;
			z__1.r = bcoeff.r * WORK(j).r - bcoeff.i * WORK(
				j).i, z__1.i = bcoeff.r * WORK(j).i + 
				bcoeff.i * WORK(j).r;
			cb.r = z__1.r, cb.i = z__1.i;
			i__1 = j - 1;
			for (jr = 1; jr <= j-1; ++jr) {
			    i__2 = jr;
			    i__3 = jr;
			    i__4 = jr + j * a_dim1;
			    z__3.r = ca.r * A(jr,j).r - ca.i * A(jr,j).i, 
				    z__3.i = ca.r * A(jr,j).i + ca.i * A(jr,j)
				    .r;
			    z__2.r = WORK(jr).r + z__3.r, z__2.i = WORK(
				    jr).i + z__3.i;
			    i__5 = jr + j * b_dim1;
			    z__4.r = cb.r * B(jr,j).r - cb.i * B(jr,j).i, 
				    z__4.i = cb.r * B(jr,j).i + cb.i * B(jr,j)
				    .r;
			    z__1.r = z__2.r - z__4.r, z__1.i = z__2.i - 
				    z__4.i;
			    WORK(jr).r = z__1.r, WORK(jr).i = z__1.i;
/* L200: */
			}
		    }
/* L210: */
		}

/*              Back transform eigenvector if HOWMNY='B'. */

		if (ilback) {
		    zgemv_("N", n, &je, &c_b2, &VR(1,1), ldvr, &WORK(1),
			     &c__1, &c_b1, &WORK(*n + 1), &c__1);
		    isrc = 2;
		    iend = *n;
		} else {
		    isrc = 1;
		    iend = je;
		}

/*              Copy and scale eigenvector into column of VR 
*/

		xmax = 0.;
		i__1 = iend;
		for (jr = 1; jr <= iend; ++jr) {
/* Computing MAX */
		    i__2 = (isrc - 1) * *n + jr;
		    d__3 = xmax, d__4 = (d__1 = WORK((isrc-1)**n+jr).r, abs(d__1)) + (
			    d__2 = d_imag(&WORK((isrc - 1) * *n + jr)), abs(
			    d__2));
		    xmax = max(d__3,d__4);
/* L220: */
		}

		if (xmax > safmin) {
		    temp = 1. / xmax;
		    i__1 = iend;
		    for (jr = 1; jr <= iend; ++jr) {
			i__2 = jr + ieig * vr_dim1;
			i__3 = (isrc - 1) * *n + jr;
			z__1.r = temp * WORK((isrc-1)**n+jr).r, z__1.i = temp * WORK(
				(isrc-1)**n+jr).i;
			VR(jr,ieig).r = z__1.r, VR(jr,ieig).i = z__1.i;
/* L230: */
		    }
		} else {
		    iend = 0;
		}

		i__1 = *n;
		for (jr = iend + 1; jr <= *n; ++jr) {
		    i__2 = jr + ieig * vr_dim1;
		    VR(jr,ieig).r = 0., VR(jr,ieig).i = 0.;
/* L240: */
		}

	    }
L250:
	    ;
	}
    }

    return 0;

/*     End of ZTGEVC */

} /* ztgevc_ */
Ejemplo n.º 22
0
/* Subroutine */ int ztrsna_(char *job, char *howmny, logical *select, 
	integer *n, doublecomplex *t, integer *ldt, doublecomplex *vl, 
	integer *ldvl, doublecomplex *vr, integer *ldvr, doublereal *s, 
	doublereal *sep, integer *mm, integer *m, doublecomplex *work, 
	integer *ldwork, doublereal *rwork, integer *info)
{
/*  -- LAPACK routine (version 2.0) --   
       Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
       Courant Institute, Argonne National Lab, and Rice University   
       September 30, 1994   


    Purpose   
    =======   

    ZTRSNA estimates reciprocal condition numbers for specified   
    eigenvalues and/or right eigenvectors of a complex upper triangular   
    matrix T (or of any matrix Q*T*Q**H with Q unitary).   

    Arguments   
    =========   

    JOB     (input) CHARACTER*1   
            Specifies whether condition numbers are required for   
            eigenvalues (S) or eigenvectors (SEP):   
            = 'E': for eigenvalues only (S);   
            = 'V': for eigenvectors only (SEP);   
            = 'B': for both eigenvalues and eigenvectors (S and SEP).   

    HOWMNY  (input) CHARACTER*1   
            = 'A': compute condition numbers for all eigenpairs;   
            = 'S': compute condition numbers for selected eigenpairs   
                   specified by the array SELECT.   

    SELECT  (input) LOGICAL array, dimension (N)   
            If HOWMNY = 'S', SELECT specifies the eigenpairs for which   
            condition numbers are required. To select condition numbers   
            for the j-th eigenpair, SELECT(j) must be set to .TRUE..   
            If HOWMNY = 'A', SELECT is not referenced.   

    N       (input) INTEGER   
            The order of the matrix T. N >= 0.   

    T       (input) COMPLEX*16 array, dimension (LDT,N)   
            The upper triangular matrix T.   

    LDT     (input) INTEGER   
            The leading dimension of the array T. LDT >= max(1,N).   

    VL      (input) COMPLEX*16 array, dimension (LDVL,M)   
            If JOB = 'E' or 'B', VL must contain left eigenvectors of T   
            (or of any Q*T*Q**H with Q unitary), corresponding to the   
            eigenpairs specified by HOWMNY and SELECT. The eigenvectors   
            must be stored in consecutive columns of VL, as returned by   
            ZHSEIN or ZTREVC.   
            If JOB = 'V', VL is not referenced.   

    LDVL    (input) INTEGER   
            The leading dimension of the array VL.   
            LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N.   

    VR      (input) COMPLEX*16 array, dimension (LDVR,M)   
            If JOB = 'E' or 'B', VR must contain right eigenvectors of T 
  
            (or of any Q*T*Q**H with Q unitary), corresponding to the   
            eigenpairs specified by HOWMNY and SELECT. The eigenvectors   
            must be stored in consecutive columns of VR, as returned by   
            ZHSEIN or ZTREVC.   
            If JOB = 'V', VR is not referenced.   

    LDVR    (input) INTEGER   
            The leading dimension of the array VR.   
            LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N.   

    S       (output) DOUBLE PRECISION array, dimension (MM)   
            If JOB = 'E' or 'B', the reciprocal condition numbers of the 
  
            selected eigenvalues, stored in consecutive elements of the   
            array. Thus S(j), SEP(j), and the j-th columns of VL and VR   
            all correspond to the same eigenpair (but not in general the 
  
            j-th eigenpair, unless all eigenpairs are selected).   
            If JOB = 'V', S is not referenced.   

    SEP     (output) DOUBLE PRECISION array, dimension (MM)   
            If JOB = 'V' or 'B', the estimated reciprocal condition   
            numbers of the selected eigenvectors, stored in consecutive   
            elements of the array.   
            If JOB = 'E', SEP is not referenced.   

    MM      (input) INTEGER   
            The number of elements in the arrays S (if JOB = 'E' or 'B') 
  
             and/or SEP (if JOB = 'V' or 'B'). MM >= M.   

    M       (output) INTEGER   
            The number of elements of the arrays S and/or SEP actually   
            used to store the estimated condition numbers.   
            If HOWMNY = 'A', M is set to N.   

    WORK    (workspace) COMPLEX*16 array, dimension (LDWORK,N+1)   
            If JOB = 'E', WORK is not referenced.   

    LDWORK  (input) INTEGER   
            The leading dimension of the array WORK.   
            LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N.   

    RWORK   (workspace) DOUBLE PRECISION array, dimension (N)   
            If JOB = 'E', RWORK is not referenced.   

    INFO    (output) INTEGER   
            = 0: successful exit   
            < 0: if INFO = -i, the i-th argument had an illegal value   

    Further Details   
    ===============   

    The reciprocal of the condition number of an eigenvalue lambda is   
    defined as   

            S(lambda) = |v'*u| / (norm(u)*norm(v))   

    where u and v are the right and left eigenvectors of T corresponding 
  
    to lambda; v' denotes the conjugate transpose of v, and norm(u)   
    denotes the Euclidean norm. These reciprocal condition numbers always 
  
    lie between zero (very badly conditioned) and one (very well   
    conditioned). If n = 1, S(lambda) is defined to be 1.   

    An approximate error bound for a computed eigenvalue W(i) is given by 
  

                        EPS * norm(T) / S(i)   

    where EPS is the machine precision.   

    The reciprocal of the condition number of the right eigenvector u   
    corresponding to lambda is defined as follows. Suppose   

                T = ( lambda  c  )   
                    (   0    T22 )   

    Then the reciprocal condition number is   

            SEP( lambda, T22 ) = sigma-min( T22 - lambda*I )   

    where sigma-min denotes the smallest singular value. We approximate   
    the smallest singular value by the reciprocal of an estimate of the   
    one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is   
    defined to be abs(T(1,1)).   

    An approximate error bound for a computed right eigenvector VR(i)   
    is given by   

                        EPS * norm(T) / SEP(i)   

    ===================================================================== 
  


       Decode and test the input parameters   

    
   Parameter adjustments   
       Function Body */
    /* Table of constant values */
    static integer c__1 = 1;
    
    /* System generated locals */
    integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, 
	    work_dim1, work_offset, i__1, i__2, i__3, i__4, i__5;
    doublereal d__1, d__2;
    doublecomplex z__1;
    /* Builtin functions */
    double z_abs(doublecomplex *), d_imag(doublecomplex *);
    /* Local variables */
    static integer kase, ierr;
    static doublecomplex prod;
    static doublereal lnrm, rnrm;
    static integer i, j, k;
    static doublereal scale;
    extern logical lsame_(char *, char *);
    extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, integer *);
    static doublecomplex dummy[1];
    static logical wants;
    static doublereal xnorm;
    extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
    extern doublereal dznrm2_(integer *, doublecomplex *, integer *), dlamch_(
	    char *);
    static integer ks, ix;
    extern /* Subroutine */ int xerbla_(char *, integer *);
    static doublereal bignum;
    static logical wantbh;
    extern /* Subroutine */ int zlacon_(integer *, doublecomplex *, 
	    doublecomplex *, doublereal *, integer *);
    extern integer izamax_(integer *, doublecomplex *, integer *);
    static logical somcon;
    extern /* Subroutine */ int zdrscl_(integer *, doublereal *, 
	    doublecomplex *, integer *);
    static char normin[1];
    extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, integer *);
    static doublereal smlnum;
    static logical wantsp;
    extern /* Subroutine */ int zlatrs_(char *, char *, char *, char *, 
	    integer *, doublecomplex *, integer *, doublecomplex *, 
	    doublereal *, doublereal *, integer *), ztrexc_(char *, integer *, doublecomplex *, integer *, 
	    doublecomplex *, integer *, integer *, integer *, integer *);
    static doublereal eps, est;



#define DUMMY(I) dummy[(I)]
#define SELECT(I) select[(I)-1]
#define S(I) s[(I)-1]
#define SEP(I) sep[(I)-1]
#define RWORK(I) rwork[(I)-1]

#define T(I,J) t[(I)-1 + ((J)-1)* ( *ldt)]
#define VL(I,J) vl[(I)-1 + ((J)-1)* ( *ldvl)]
#define VR(I,J) vr[(I)-1 + ((J)-1)* ( *ldvr)]
#define WORK(I,J) work[(I)-1 + ((J)-1)* ( *ldwork)]

    wantbh = lsame_(job, "B");
    wants = lsame_(job, "E") || wantbh;
    wantsp = lsame_(job, "V") || wantbh;

    somcon = lsame_(howmny, "S");

/*     Set M to the number of eigenpairs for which condition numbers are 
  
       to be computed. */

    if (somcon) {
	*m = 0;
	i__1 = *n;
	for (j = 1; j <= *n; ++j) {
	    if (SELECT(j)) {
		++(*m);
	    }
/* L10: */
	}
    } else {
	*m = *n;
    }

    *info = 0;
    if (! wants && ! wantsp) {
	*info = -1;
    } else if (! lsame_(howmny, "A") && ! somcon) {
	*info = -2;
    } else if (*n < 0) {
	*info = -4;
    } else if (*ldt < max(1,*n)) {
	*info = -6;
    } else if (*ldvl < 1 || wants && *ldvl < *n) {
	*info = -8;
    } else if (*ldvr < 1 || wants && *ldvr < *n) {
	*info = -10;
    } else if (*mm < *m) {
	*info = -13;
    } else if (*ldwork < 1 || wantsp && *ldwork < *n) {
	*info = -16;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("ZTRSNA", &i__1);
	return 0;
    }

/*     Quick return if possible */

    if (*n == 0) {
	return 0;
    }

    if (*n == 1) {
	if (somcon) {
	    if (! SELECT(1)) {
		return 0;
	    }
	}
	if (wants) {
	    S(1) = 1.;
	}
	if (wantsp) {
	    SEP(1) = z_abs(&T(1,1));
	}
	return 0;
    }

/*     Get machine constants */

    eps = dlamch_("P");
    smlnum = dlamch_("S") / eps;
    bignum = 1. / smlnum;
    dlabad_(&smlnum, &bignum);

    ks = 1;
    i__1 = *n;
    for (k = 1; k <= *n; ++k) {

	if (somcon) {
	    if (! SELECT(k)) {
		goto L50;
	    }
	}

	if (wants) {

/*           Compute the reciprocal condition number of the k-th 
  
             eigenvalue. */

	    zdotc_(&z__1, n, &VR(1,ks), &c__1, &VL(1,ks), &c__1);
	    prod.r = z__1.r, prod.i = z__1.i;
	    rnrm = dznrm2_(n, &VR(1,ks), &c__1);
	    lnrm = dznrm2_(n, &VL(1,ks), &c__1);
	    S(ks) = z_abs(&prod) / (rnrm * lnrm);

	}

	if (wantsp) {

/*           Estimate the reciprocal condition number of the k-th 
  
             eigenvector.   

             Copy the matrix T to the array WORK and swap the k-th
   
             diagonal element to the (1,1) position. */

	    zlacpy_("Full", n, n, &T(1,1), ldt, &WORK(1,1), 
		    ldwork);
	    ztrexc_("No Q", n, &WORK(1,1), ldwork, dummy, &c__1, &k, &
		    c__1, &ierr);

/*           Form  C = T22 - lambda*I in WORK(2:N,2:N). */

	    i__2 = *n;
	    for (i = 2; i <= *n; ++i) {
		i__3 = i + i * work_dim1;
		i__4 = i + i * work_dim1;
		i__5 = work_dim1 + 1;
		z__1.r = WORK(i,i).r - WORK(1,1).r, z__1.i = WORK(i,i).i - 
			WORK(1,1).i;
		WORK(i,i).r = z__1.r, WORK(i,i).i = z__1.i;
/* L20: */
	    }

/*           Estimate a lower bound for the 1-norm of inv(C'). The
 1st   
             and (N+1)th columns of WORK are used to store work ve
ctors. */

	    SEP(ks) = 0.;
	    est = 0.;
	    kase = 0;
	    *(unsigned char *)normin = 'N';
L30:
	    i__2 = *n - 1;
	    zlacon_(&i__2, &WORK(1,*n+1), &WORK(1,1)
		    , &est, &kase);

	    if (kase != 0) {
		if (kase == 1) {

/*                 Solve C'*x = scale*b */

		    i__2 = *n - 1;
		    zlatrs_("Upper", "Conjugate transpose", "Nonunit", normin,
			     &i__2, &WORK(2,2), ldwork, &
			    WORK(1,1), &scale, &RWORK(1), &ierr);
		} else {

/*                 Solve C*x = scale*b */

		    i__2 = *n - 1;
		    zlatrs_("Upper", "No transpose", "Nonunit", normin, &i__2,
			     &WORK(2,2), ldwork, &WORK(1,1), &scale, &RWORK(1), &ierr);
		}
		*(unsigned char *)normin = 'Y';
		if (scale != 1.) {

/*                 Multiply by 1/SCALE if doing so will no
t cause   
                   overflow. */

		    i__2 = *n - 1;
		    ix = izamax_(&i__2, &WORK(1,1), &c__1);
		    i__2 = ix + work_dim1;
		    xnorm = (d__1 = WORK(ix,1).r, abs(d__1)) + (d__2 = d_imag(
			    &WORK(ix,1)), abs(d__2));
		    if (scale < xnorm * smlnum || scale == 0.) {
			goto L40;
		    }
		    zdrscl_(n, &scale, &WORK(1,1), &c__1);
		}
		goto L30;
	    }

	    SEP(ks) = 1. / max(est,smlnum);
	}

L40:
	++ks;
L50:
	;
    }
    return 0;

/*     End of ZTRSNA */

} /* ztrsna_ */
Ejemplo n.º 23
0
/*>BOOL blFitCaPDB(PDB *ref_pdb, PDB *fit_pdb, REAL rm[3][3])
   --------------------------------------------------------
*//**

   \param[in]     *ref_pdb     Reference PDB linked list
   \param[in,out] *fit_pdb     Mobile PDB linked list
   \param[out]    rm           Rotation matrix (May be input as NULL).
   \return                      Success

   Fits two PDB linked lists using only the CA atoms. 

   Actually fits fit_pdb onto ref_pdb and also returns the rotation 
   matrix. This may be NULL if these data are not required.

-  14.03.96 Original based on FitPDB()   By: ACRM
-  28.01.09 Initialize RetVal to TRUE!
-  07.07.14 Use bl prefix for functions By: CTP
-  19.08.14 Added AsCopy suffix to calls to blSelectAtomsPDB() By: CTP
*/
BOOL blFitCaPDB(PDB *ref_pdb, PDB *fit_pdb, REAL rm[3][3])
{
   REAL  RotMat[3][3];
   COOR  *ref_coor   = NULL,
         *fit_coor   = NULL;
   VEC3F ref_ca_CofG,
         fit_ca_CofG,
         tvect;
   int   NCoor       = 0,
         i, j,
         natoms;
   BOOL  RetVal = TRUE;
   PDB   *ref_ca_pdb = NULL,
         *fit_ca_pdb = NULL;
   char  *sel[2];

   /* First extract only the CA atoms                                   */
   SELECT(sel[0], "CA  ");
   if(sel[0]==NULL)
      return(FALSE);
   if( (ref_ca_pdb = blSelectAtomsPDBAsCopy(ref_pdb, 1, sel, &natoms))
       == NULL )
      RetVal = FALSE;
   if( (fit_ca_pdb = blSelectAtomsPDBAsCopy(fit_pdb, 1, sel, &natoms))
       == NULL )
      RetVal = FALSE;
   free(sel[0]);
   
   /* If we succeeded in building our CA PDB linked lists...            */
   if(RetVal)
   {
      /* Get the CofG of the CA structures and the original mobile      */
      blGetCofGPDB(ref_ca_pdb, &ref_ca_CofG);
      blGetCofGPDB(fit_ca_pdb, &fit_ca_CofG);
      
      /* Move them both to the origin                                   */
      blOriginPDB(ref_ca_pdb);
      blOriginPDB(fit_ca_pdb);
      
      /* Create coordinate arrays, checking numbers match               */
      NCoor = blGetPDBCoor(ref_ca_pdb, &ref_coor);
      if(blGetPDBCoor(fit_ca_pdb, &fit_coor) != NCoor)
      {
         RetVal = FALSE;
      }
      else
      {
         /* Can't fit with fewer than 3 coordinates                     */
         if(NCoor < 3)
         {
            RetVal = FALSE;
         }
         else
         {
            /* Everything OK, go ahead with the fitting                 */
            if(!blMatfit(ref_coor,fit_coor,RotMat,NCoor,NULL,FALSE))
            {
               RetVal = FALSE;
            }
            else
            {
               /* Apply the operations to the true coordinates          */
               tvect.x = (-fit_ca_CofG.x);
               tvect.y = (-fit_ca_CofG.y);
               tvect.z = (-fit_ca_CofG.z);
               blTranslatePDB(fit_pdb, tvect);
               blApplyMatrixPDB(fit_pdb, RotMat);
               blTranslatePDB(fit_pdb, ref_ca_CofG);
            }
         }
      }
   }
   
   /* Free the coordinate arrays and CA PDB linked lists                */
   if(ref_coor)   free(ref_coor);
   if(fit_coor)   free(fit_coor);
   if(ref_ca_pdb) FREELIST(ref_ca_pdb, PDB);
   if(fit_ca_pdb) FREELIST(fit_ca_pdb, PDB);
         
   /* Fill in the rotation matrix for output, if required               */
   if(RetVal && (rm!=NULL))
   {
      for(i=0; i<3; i++)
         for(j=0; j<3; j++)
            rm[i][j] = RotMat[i][j];
   }

   return(RetVal);
}
Ejemplo n.º 24
0
void start_timer(unsigned r0, unsigned r1, unsigned r2, unsigned r3)
{
	int val;
	int i;

#define BIT(n) (1<<n)
#define BITTST(val, n) ((val) & BIT(n))
#define TST(val, b) ((val) & (b))

	hw_timer_rotary[0] = (void *)(0x80068000); /* have ROTCTRL */
	hw_timer_rotary[1] = (void *)(0x80068050);
	hw_timer_rotary[2] = (void *)(0x80068080);
	hw_timer_rotary[3] = (void *)(0x800680C0);

	val = hw_timer_rotary[0]->HW_TIMROT_ROTCTRL[0];
	printk("This SoC has:\n");
	if(BITTST(val,25)) printk("timer 0\n");
	if(BITTST(val,26)) printk("timer 1\n");
	if(BITTST(val,27)) printk("timer 2\n");
	if(BITTST(val,28)) printk("timer 3\n");

#define IRQ         (1<<15)
#define IRQ_EN      (1<<14)
#define MATCH_MODE  (1<<11)
#define POLARITY    (1<<8)
#define UPDATE      (1<<7)
#define RELOAD      (1<<6)
#define PRESCALE(n) ((n)<<4)
  #define DIV_BY_8     (0x3)
#define SELECT(n)   ((n)<<0)
  #define TICK_ALWAYS  (0XF)


#define SET 1
#define CLR 2
#define TOG 3

	hw_timer_rotary[1]->HW_TIMROT_FIXED_COUNT[0] = 0x00011000;
	val = IRQ_EN | UPDATE | RELOAD | PRESCALE(TICK_ALWAYS) | SELECT(0xB);
	out_w(HW_TIMROT_TIMCTRL1, val);

	while(1){
		static int random = 0;

		random++;
		printk("[%04d]wait timer1 irq\n", random);
		waitMsec(100);
		val = hw_timer_rotary[1]->HW_TIMROT_TIMCTRL[0];
		printk("%016b\n", val);
		val = in_w(HW_TIMROT_RUNNING_COUNT1);
		printk("timer running @[0x%x]\n", val);
		val = in_w(HW_TIMROT_VERSION);
		printk("timer version @[%X]\n", val);

		if(random>300) break;
	}

	printk("Goodbye TIMER!\n");
		
	
}
Ejemplo n.º 25
0
getname(char *defname, char *defpasswd)

/* Let person identify themselves from w */
{
  register char ch;
  int     secondsLeft = 199, laststate;
  char    tempstr[40];
  LONG    lasttime;
  char   *namptr, *passptr;
  register int j;
  struct timeval timeout;
  fd_set  readfds;

  autolog = (*defpasswd && *defname) ? 1 : 0;

  MZERO(mystats, sizeof(struct stats));

  mystats->st_tticks = 1;
  for (j = 0; j < 95; j++)
    {
      mystats->st_keymap[j] = j + 32;
      mystats->st_keymap[j + 96] = j + 32 + 96;

#ifdef MOUSE_AS_SHIFT
      mystats->st_keymap[j + 192] = j + 32;
      mystats->st_keymap[j + 288] = j + 32;
      mystats->st_keymap[j + 384] = j + 32;
#endif
    }
  mystats->st_keymap[95] = 0;
  mystats->st_flags = ST_MAPMODE + ST_NAMEMODE + ST_SHOWSHIELDS +
      ST_KEEPPEACE + ST_SHOWLOCAL * 2 + ST_SHOWGLOBAL * 2;

  lasttime = time(NULL);

  if (ghoststart)
    return;

  tempname[0] = '\0';
  password1[0] = '\0';
  password2[0] = '\0';

  laststate = state = ST_GETNAME;
  displayStartup(defname);
  while (1)
    {
      handleWEvents(defname);

      if (!autolog)
  {

#ifndef HAVE_WIN32
    W_FullScreen(baseWin);
    timeout.tv_sec = 1;
    timeout.tv_usec = 0;
#else
    /* Since we don't have a socket to check on Win32 for windowing *
     * system events, we set the timeout to zero and effectively poll.
     * * Yes, I could do the correct thing and call *
     * WaitForMultipleObjects() etc. but I don't feel like it */
    timeout.tv_sec = 0;
    timeout.tv_usec = 100000;
#endif

    FD_ZERO(&readfds);
    FD_SET(sock, &readfds);
    if (udpSock >= 0)
      FD_SET(udpSock, &readfds);

#ifndef HAVE_WIN32
    FD_SET(W_Socket(), &readfds);
#endif

    if (SELECT(32, &readfds, 0, 0, &timeout) < 0)
      {
        perror("select");
        continue;
      }

    if (FD_ISSET(sock, &readfds)
        || (udpSock >= 0 && FD_ISSET(udpSock, &readfds)))
      readFromServer(&readfds);

#ifndef HAVE_WIN32
    if (FD_ISSET(W_Socket(), &readfds))
#else
    if (W_EventsPending())
#endif

      handleWEvents(defname);
  }
      else
  {
    readFromServer(&readfds);
  }

      if (isServerDead())
  {
    printf("Shit, we were ghostbusted\n");

#ifdef HAVE_XPM
    W_GalacticBgd(GHOST_PIX);
#endif

#ifdef AUTOKEY
    if (autoKey)
      W_AutoRepeatOn();
#endif

    terminate(0);
  }

      if (time(0) != lasttime)
  {
    lasttime++;
    secondsLeft--;
    showreadme();
    if (!autolog)
      {
        sprintf(tempstr, "Seconds to go: %d ", secondsLeft);
        W_WriteText(w, 100, 400, textColor, tempstr, strlen(tempstr),
        W_RegularFont);
      }
    if (secondsLeft == 0)
      {
        me->p_status = PFREE;
        printf("Timed Out.\n");

#ifdef AUTOKEY
        if (autoKey)
    W_AutoRepeatOn();
#endif

        terminate(0);
      }
  }
      if (state == ST_DONE)
  {
    W_ClearWindow(w);
    W_ClearWindow(mapw);
    return;
  }
      if (autolog)
  {
    switch (state)
      {
      case ST_GETNAME:
        tempname[0] = '\0';
        ch = 13;
        j = 0;
        break;

      case ST_GETPASS:
      case ST_MAKEPASS1:
      case ST_MAKEPASS2:
        ch = defpasswd[j++];
        if (ch == '\0')
    {
      j = 0;
      ch = 13;
    }
        break;

      default:
        break;
      }

    loginproced(ch, defname);

  }

      laststate = state;
    }
}
Ejemplo n.º 26
0
scandir(const char *dirname, struct dirent ***namelist,
    int (*select)(const struct dirent *), int (*dcomp)(const struct dirent **,
	const struct dirent **))
#endif
{
	struct dirent *d, *p, **names = NULL;
	size_t arraysz, numitems;
	DIR *dirp;

	if ((dirp = opendir(dirname)) == NULL)
		return(-1);

	numitems = 0;
	arraysz = 32;	/* initial estimate of the array size */
	names = (struct dirent **)malloc(arraysz * sizeof(struct dirent *));
	if (names == NULL)
		goto fail;

	while ((d = readdir(dirp)) != NULL) {
		if (select != NULL && !SELECT(d))
			continue;	/* just selected names */
		/*
		 * Make a minimum size copy of the data
		 */
		p = (struct dirent *)malloc(_GENERIC_DIRSIZ(d));
		if (p == NULL)
			goto fail;
		p->d_fileno = d->d_fileno;
		p->d_type = d->d_type;
		p->d_reclen = d->d_reclen;
		p->d_namlen = d->d_namlen;
		bcopy(d->d_name, p->d_name, p->d_namlen + 1);
		/*
		 * Check to make sure the array has space left and
		 * realloc the maximum size.
		 */
		if (numitems >= arraysz) {
			struct dirent **names2;

			names2 = reallocarray(names, arraysz,
			    2 * sizeof(struct dirent *));
			if (names2 == NULL) {
				free(p);
				goto fail;
			}
			names = names2;
			arraysz *= 2;
		}
		names[numitems++] = p;
	}
	closedir(dirp);
	if (numitems && dcomp != NULL)
#ifdef I_AM_SCANDIR_B
		qsort_b(names, numitems, sizeof(struct dirent *), (void*)dcomp);
#else
		qsort_r(names, numitems, sizeof(struct dirent *),
		    &dcomp, alphasort_thunk);
#endif
	*namelist = names;
	return (numitems);

fail:
	while (numitems > 0)
		free(names[--numitems]);
	free(names);
	closedir(dirp);
	return (-1);
}
Ejemplo n.º 27
0
/* Subroutine */ int dtrsna_(char *job, char *howmny, logical *select, 
	integer *n, doublereal *t, integer *ldt, doublereal *vl, integer *
	ldvl, doublereal *vr, integer *ldvr, doublereal *s, doublereal *sep, 
	integer *mm, integer *m, doublereal *work, integer *ldwork, integer *
	iwork, integer *info)
{
/*  -- LAPACK routine (version 2.0) --   
       Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
       Courant Institute, Argonne National Lab, and Rice University   
       September 30, 1994   


    Purpose   
    =======   

    DTRSNA estimates reciprocal condition numbers for specified   
    eigenvalues and/or right eigenvectors of a real upper   
    quasi-triangular matrix T (or of any matrix Q*T*Q**T with Q   
    orthogonal).   

    T must be in Schur canonical form (as returned by DHSEQR), that is,   
    block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each   
    2-by-2 diagonal block has its diagonal elements equal and its   
    off-diagonal elements of opposite sign.   

    Arguments   
    =========   

    JOB     (input) CHARACTER*1   
            Specifies whether condition numbers are required for   
            eigenvalues (S) or eigenvectors (SEP):   
            = 'E': for eigenvalues only (S);   
            = 'V': for eigenvectors only (SEP);   
            = 'B': for both eigenvalues and eigenvectors (S and SEP).   

    HOWMNY  (input) CHARACTER*1   
            = 'A': compute condition numbers for all eigenpairs;   
            = 'S': compute condition numbers for selected eigenpairs   
                   specified by the array SELECT.   

    SELECT  (input) LOGICAL array, dimension (N)   
            If HOWMNY = 'S', SELECT specifies the eigenpairs for which   
            condition numbers are required. To select condition numbers   
            for the eigenpair corresponding to a real eigenvalue w(j),   
            SELECT(j) must be set to .TRUE.. To select condition numbers 
  
            corresponding to a complex conjugate pair of eigenvalues w(j) 
  
            and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be 
  
            set to .TRUE..   
            If HOWMNY = 'A', SELECT is not referenced.   

    N       (input) INTEGER   
            The order of the matrix T. N >= 0.   

    T       (input) DOUBLE PRECISION array, dimension (LDT,N)   
            The upper quasi-triangular matrix T, in Schur canonical form. 
  

    LDT     (input) INTEGER   
            The leading dimension of the array T. LDT >= max(1,N).   

    VL      (input) DOUBLE PRECISION array, dimension (LDVL,M)   
            If JOB = 'E' or 'B', VL must contain left eigenvectors of T   
            (or of any Q*T*Q**T with Q orthogonal), corresponding to the 
  
            eigenpairs specified by HOWMNY and SELECT. The eigenvectors   
            must be stored in consecutive columns of VL, as returned by   
            DHSEIN or DTREVC.   
            If JOB = 'V', VL is not referenced.   

    LDVL    (input) INTEGER   
            The leading dimension of the array VL.   
            LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N.   

    VR      (input) DOUBLE PRECISION array, dimension (LDVR,M)   
            If JOB = 'E' or 'B', VR must contain right eigenvectors of T 
  
            (or of any Q*T*Q**T with Q orthogonal), corresponding to the 
  
            eigenpairs specified by HOWMNY and SELECT. The eigenvectors   
            must be stored in consecutive columns of VR, as returned by   
            DHSEIN or DTREVC.   
            If JOB = 'V', VR is not referenced.   

    LDVR    (input) INTEGER   
            The leading dimension of the array VR.   
            LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N.   

    S       (output) DOUBLE PRECISION array, dimension (MM)   
            If JOB = 'E' or 'B', the reciprocal condition numbers of the 
  
            selected eigenvalues, stored in consecutive elements of the   
            array. For a complex conjugate pair of eigenvalues two   
            consecutive elements of S are set to the same value. Thus   
            S(j), SEP(j), and the j-th columns of VL and VR all   
            correspond to the same eigenpair (but not in general the   
            j-th eigenpair, unless all eigenpairs are selected).   
            If JOB = 'V', S is not referenced.   

    SEP     (output) DOUBLE PRECISION array, dimension (MM)   
            If JOB = 'V' or 'B', the estimated reciprocal condition   
            numbers of the selected eigenvectors, stored in consecutive   
            elements of the array. For a complex eigenvector two   
            consecutive elements of SEP are set to the same value. If   
            the eigenvalues cannot be reordered to compute SEP(j), SEP(j) 
  
            is set to 0; this can only occur when the true value would be 
  
            very small anyway.   
            If JOB = 'E', SEP is not referenced.   

    MM      (input) INTEGER   
            The number of elements in the arrays S (if JOB = 'E' or 'B') 
  
             and/or SEP (if JOB = 'V' or 'B'). MM >= M.   

    M       (output) INTEGER   
            The number of elements of the arrays S and/or SEP actually   
            used to store the estimated condition numbers.   
            If HOWMNY = 'A', M is set to N.   

    WORK    (workspace) DOUBLE PRECISION array, dimension (LDWORK,N+1)   
            If JOB = 'E', WORK is not referenced.   

    LDWORK  (input) INTEGER   
            The leading dimension of the array WORK.   
            LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N.   

    IWORK   (workspace) INTEGER array, dimension (N)   
            If JOB = 'E', IWORK is not referenced.   

    INFO    (output) INTEGER   
            = 0: successful exit   
            < 0: if INFO = -i, the i-th argument had an illegal value   

    Further Details   
    ===============   

    The reciprocal of the condition number of an eigenvalue lambda is   
    defined as   

            S(lambda) = |v'*u| / (norm(u)*norm(v))   

    where u and v are the right and left eigenvectors of T corresponding 
  
    to lambda; v' denotes the conjugate-transpose of v, and norm(u)   
    denotes the Euclidean norm. These reciprocal condition numbers always 
  
    lie between zero (very badly conditioned) and one (very well   
    conditioned). If n = 1, S(lambda) is defined to be 1.   

    An approximate error bound for a computed eigenvalue W(i) is given by 
  

                        EPS * norm(T) / S(i)   

    where EPS is the machine precision.   

    The reciprocal of the condition number of the right eigenvector u   
    corresponding to lambda is defined as follows. Suppose   

                T = ( lambda  c  )   
                    (   0    T22 )   

    Then the reciprocal condition number is   

            SEP( lambda, T22 ) = sigma-min( T22 - lambda*I )   

    where sigma-min denotes the smallest singular value. We approximate   
    the smallest singular value by the reciprocal of an estimate of the   
    one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is   
    defined to be abs(T(1,1)).   

    An approximate error bound for a computed right eigenvector VR(i)   
    is given by   

                        EPS * norm(T) / SEP(i)   

    ===================================================================== 
  


       Decode and test the input parameters   

    
   Parameter adjustments   
       Function Body */
    /* Table of constant values */
    static integer c__1 = 1;
    static logical c_true = TRUE_;
    static logical c_false = FALSE_;
    
    /* System generated locals */
    integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, 
	    work_dim1, work_offset, i__1, i__2;
    doublereal d__1, d__2;
    /* Builtin functions */
    double sqrt(doublereal);
    /* Local variables */
    static integer kase;
    static doublereal cond;
    extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, 
	    integer *);
    static logical pair;
    static integer ierr;
    static doublereal dumm, prod;
    static integer ifst;
    static doublereal lnrm;
    static integer ilst;
    static doublereal rnrm;
    extern doublereal dnrm2_(integer *, doublereal *, integer *);
    static doublereal prod1, prod2;
    static integer i, j, k;
    static doublereal scale, delta;
    extern logical lsame_(char *, char *);
    static logical wants;
    static doublereal dummy[1];
    static integer n2;
    extern doublereal dlapy2_(doublereal *, doublereal *);
    extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
    static doublereal cs;
    extern doublereal dlamch_(char *);
    static integer nn, ks;
    extern /* Subroutine */ int dlacon_(integer *, doublereal *, doublereal *,
	     integer *, doublereal *, integer *);
    static doublereal sn, mu;
    extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, 
	    doublereal *, integer *, doublereal *, integer *), 
	    xerbla_(char *, integer *);
    static doublereal bignum;
    static logical wantbh;
    extern /* Subroutine */ int dlaqtr_(logical *, logical *, integer *, 
	    doublereal *, integer *, doublereal *, doublereal *, doublereal *,
	     doublereal *, doublereal *, integer *), dtrexc_(char *, integer *
	    , doublereal *, integer *, doublereal *, integer *, integer *, 
	    integer *, doublereal *, integer *);
    static logical somcon;
    static doublereal smlnum;
    static logical wantsp;
    static doublereal eps, est;



#define DUMMY(I) dummy[(I)]
#define SELECT(I) select[(I)-1]
#define S(I) s[(I)-1]
#define SEP(I) sep[(I)-1]
#define IWORK(I) iwork[(I)-1]

#define T(I,J) t[(I)-1 + ((J)-1)* ( *ldt)]
#define VL(I,J) vl[(I)-1 + ((J)-1)* ( *ldvl)]
#define VR(I,J) vr[(I)-1 + ((J)-1)* ( *ldvr)]
#define WORK(I,J) work[(I)-1 + ((J)-1)* ( *ldwork)]

    wantbh = lsame_(job, "B");
    wants = lsame_(job, "E") || wantbh;
    wantsp = lsame_(job, "V") || wantbh;

    somcon = lsame_(howmny, "S");

    *info = 0;
    if (! wants && ! wantsp) {
	*info = -1;
    } else if (! lsame_(howmny, "A") && ! somcon) {
	*info = -2;
    } else if (*n < 0) {
	*info = -4;
    } else if (*ldt < max(1,*n)) {
	*info = -6;
    } else if (*ldvl < 1 || wants && *ldvl < *n) {
	*info = -8;
    } else if (*ldvr < 1 || wants && *ldvr < *n) {
	*info = -10;
    } else {

/*        Set M to the number of eigenpairs for which condition number
s   
          are required, and test MM. */

	if (somcon) {
	    *m = 0;
	    pair = FALSE_;
	    i__1 = *n;
	    for (k = 1; k <= *n; ++k) {
		if (pair) {
		    pair = FALSE_;
		} else {
		    if (k < *n) {
			if (T(k+1,k) == 0.) {
			    if (SELECT(k)) {
				++(*m);
			    }
			} else {
			    pair = TRUE_;
			    if (SELECT(k) || SELECT(k + 1)) {
				*m += 2;
			    }
			}
		    } else {
			if (SELECT(*n)) {
			    ++(*m);
			}
		    }
		}
/* L10: */
	    }
	} else {
	    *m = *n;
	}

	if (*mm < *m) {
	    *info = -13;
	} else if (*ldwork < 1 || wantsp && *ldwork < *n) {
	    *info = -16;
	}
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("DTRSNA", &i__1);
	return 0;
    }

/*     Quick return if possible */

    if (*n == 0) {
	return 0;
    }

    if (*n == 1) {
	if (somcon) {
	    if (! SELECT(1)) {
		return 0;
	    }
	}
	if (wants) {
	    S(1) = 1.;
	}
	if (wantsp) {
	    SEP(1) = (d__1 = T(1,1), abs(d__1));
	}
	return 0;
    }

/*     Get machine constants */

    eps = dlamch_("P");
    smlnum = dlamch_("S") / eps;
    bignum = 1. / smlnum;
    dlabad_(&smlnum, &bignum);

    ks = 0;
    pair = FALSE_;
    i__1 = *n;
    for (k = 1; k <= *n; ++k) {

/*        Determine whether T(k,k) begins a 1-by-1 or 2-by-2 block. */

	if (pair) {
	    pair = FALSE_;
	    goto L60;
	} else {
	    if (k < *n) {
		pair = T(k+1,k) != 0.;
	    }
	}

/*        Determine whether condition numbers are required for the k-t
h   
          eigenpair. */

	if (somcon) {
	    if (pair) {
		if (! SELECT(k) && ! SELECT(k + 1)) {
		    goto L60;
		}
	    } else {
		if (! SELECT(k)) {
		    goto L60;
		}
	    }
	}

	++ks;

	if (wants) {

/*           Compute the reciprocal condition number of the k-th 
  
             eigenvalue. */

	    if (! pair) {

/*              Real eigenvalue. */

		prod = ddot_(n, &VR(1,ks), &c__1, &VL(1,ks), &c__1);
		rnrm = dnrm2_(n, &VR(1,ks), &c__1);
		lnrm = dnrm2_(n, &VL(1,ks), &c__1);
		S(ks) = abs(prod) / (rnrm * lnrm);
	    } else {

/*              Complex eigenvalue. */

		prod1 = ddot_(n, &VR(1,ks), &c__1, &VL(1,ks), &c__1);
		prod1 += ddot_(n, &VR(1,ks+1), &c__1, &VL(1,ks+1), &c__1);
		prod2 = ddot_(n, &VL(1,ks), &c__1, &VR(1,ks+1), &c__1);
		prod2 -= ddot_(n, &VL(1,ks+1), &c__1, &VR(1,ks), &c__1);
		d__1 = dnrm2_(n, &VR(1,ks), &c__1);
		d__2 = dnrm2_(n, &VR(1,ks+1), &c__1);
		rnrm = dlapy2_(&d__1, &d__2);
		d__1 = dnrm2_(n, &VL(1,ks), &c__1);
		d__2 = dnrm2_(n, &VL(1,ks+1), &c__1);
		lnrm = dlapy2_(&d__1, &d__2);
		cond = dlapy2_(&prod1, &prod2) / (rnrm * lnrm);
		S(ks) = cond;
		S(ks + 1) = cond;
	    }
	}

	if (wantsp) {

/*           Estimate the reciprocal condition number of the k-th 
  
             eigenvector.   

             Copy the matrix T to the array WORK and swap the diag
onal   
             block beginning at T(k,k) to the (1,1) position. */

	    dlacpy_("Full", n, n, &T(1,1), ldt, &WORK(1,1), 
		    ldwork);
	    ifst = k;
	    ilst = 1;
	    dtrexc_("No Q", n, &WORK(1,1), ldwork, dummy, &c__1, &
		    ifst, &ilst, &WORK(1,*n+1), &ierr);

	    if (ierr == 1 || ierr == 2) {

/*              Could not swap because blocks not well separat
ed */

		scale = 1.;
		est = bignum;
	    } else {

/*              Reordering successful */

		if (WORK(2,1) == 0.) {

/*                 Form C = T22 - lambda*I in WORK(2:N,2:N
). */

		    i__2 = *n;
		    for (i = 2; i <= *n; ++i) {
			WORK(i,i) -= WORK(1,1);
/* L20: */
		    }
		    n2 = 1;
		    nn = *n - 1;
		} else {

/*                 Triangularize the 2 by 2 block by unita
ry   
                   transformation U = [  cs   i*ss ]   
                                      [ i*ss   cs  ].   
                   such that the (1,1) position of WORK is
 complex   
                   eigenvalue lambda with positive imagina
ry part. (2,2)   
                   position of WORK is the complex eigenva
lue lambda   
                   with negative imaginary  part. */

		    mu = sqrt((d__1 = WORK(1,2), abs(d__1))) 
			    * sqrt((d__2 = WORK(2,1), abs(d__2)));
		    delta = dlapy2_(&mu, &WORK(2,1));
		    cs = mu / delta;
		    sn = -WORK(2,1) / delta;

/*                 Form   

                   C' = WORK(2:N,2:N) + i*[rwork(1) ..... 
rwork(n-1) ]   
                                          [   mu          
           ]   
                                          [         ..    
           ]   
                                          [             ..
           ]   
                                          [               
   mu      ]   
                   where C' is conjugate transpose of comp
lex matrix C,   
                   and RWORK is stored starting in the N+1
-st column of   
                   WORK. */

		    i__2 = *n;
		    for (j = 3; j <= *n; ++j) {
			WORK(2,j) = cs * WORK(2,j)
				;
			WORK(j,j) -= WORK(1,1);
/* L30: */
		    }
		    WORK(2,2) = 0.;

		    WORK(1,*n+1) = mu * 2.;
		    i__2 = *n - 1;
		    for (i = 2; i <= *n-1; ++i) {
			WORK(i,*n+1) = sn * WORK(1,i+1);
/* L40: */
		    }
		    n2 = 2;
		    nn = *n - 1 << 1;
		}

/*              Estimate norm(inv(C')) */

		est = 0.;
		kase = 0;
L50:
		dlacon_(&nn, &WORK(1,*n+2), &WORK(1,*n+4), &IWORK(1), &est, &kase);
		if (kase != 0) {
		    if (kase == 1) {
			if (n2 == 1) {

/*                       Real eigenvalue: solve C'
*x = scale*c. */

			    i__2 = *n - 1;
			    dlaqtr_(&c_true, &c_true, &i__2, &WORK(2,2), ldwork, dummy, &dumm, &scale, 
				    &WORK(1,*n+4), &WORK(1,*n+6), &ierr);
			} else {

/*                       Complex eigenvalue: solve
   
                         C'*(p+iq) = scale*(c+id) 
in real arithmetic. */

			    i__2 = *n - 1;
			    dlaqtr_(&c_true, &c_false, &i__2, &WORK(2,2), ldwork, &WORK(1,*n+1), &mu, &scale, &WORK(1,*n+4), &WORK(1,*n+6), &ierr);
			}
		    } else {
			if (n2 == 1) {

/*                       Real eigenvalue: solve C*
x = scale*c. */

			    i__2 = *n - 1;
			    dlaqtr_(&c_false, &c_true, &i__2, &WORK(2,2), ldwork, dummy, &
				    dumm, &scale, &WORK(1,*n+4), &WORK(1,*n+6), &
				    ierr);
			} else {

/*                       Complex eigenvalue: solve
   
                         C*(p+iq) = scale*(c+id) i
n real arithmetic. */

			    i__2 = *n - 1;
			    dlaqtr_(&c_false, &c_false, &i__2, &WORK(2,2), ldwork, &WORK(1,*n+1), &mu, &scale, &WORK(1,*n+4), &WORK(1,*n+6), &ierr);

			}
		    }

		    goto L50;
		}
	    }

	    SEP(ks) = scale / max(est,smlnum);
	    if (pair) {
		SEP(ks + 1) = SEP(ks);
	    }
	}

	if (pair) {
	    ++ks;
	}

L60:
	;
    }
    return 0;

/*     End of DTRSNA */

} /* dtrsna_ */
Ejemplo n.º 28
0
int vfc_init_i2c_bus(struct vfc_dev *dev)
{
	WRITE_S1(ENABLE_SERIAL | SELECT(S0) | ACK);
	vfc_i2c_reset_bus(dev);
	return 0;
}